1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Eval_Fat; use Eval_Fat;
33 with Exp_Util; use Exp_Util;
34 with Freeze; use Freeze;
36 with Namet; use Namet;
37 with Nmake; use Nmake;
38 with Nlists; use Nlists;
40 with Par_SCO; use Par_SCO;
41 with Rtsfind; use Rtsfind;
43 with Sem_Aux; use Sem_Aux;
44 with Sem_Cat; use Sem_Cat;
45 with Sem_Ch6; use Sem_Ch6;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Res; use Sem_Res;
48 with Sem_Util; use Sem_Util;
49 with Sem_Type; use Sem_Type;
50 with Sem_Warn; use Sem_Warn;
51 with Sinfo; use Sinfo;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Stringt; use Stringt;
55 with Tbuild; use Tbuild;
57 package body Sem_Eval is
59 -----------------------------------------
60 -- Handling of Compile Time Evaluation --
61 -----------------------------------------
63 -- The compile time evaluation of expressions is distributed over several
64 -- Eval_xxx procedures. These procedures are called immediately after
65 -- a subexpression is resolved and is therefore accomplished in a bottom
66 -- up fashion. The flags are synthesized using the following approach.
68 -- Is_Static_Expression is determined by following the detailed rules
69 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
70 -- flag of the operands in many cases.
72 -- Raises_Constraint_Error is set if any of the operands have the flag
73 -- set or if an attempt to compute the value of the current expression
74 -- results in detection of a runtime constraint error.
76 -- As described in the spec, the requirement is that Is_Static_Expression
77 -- be accurately set, and in addition for nodes for which this flag is set,
78 -- Raises_Constraint_Error must also be set. Furthermore a node which has
79 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
80 -- requirement is that the expression value must be precomputed, and the
81 -- node is either a literal, or the name of a constant entity whose value
82 -- is a static expression.
84 -- The general approach is as follows. First compute Is_Static_Expression.
85 -- If the node is not static, then the flag is left off in the node and
86 -- we are all done. Otherwise for a static node, we test if any of the
87 -- operands will raise constraint error, and if so, propagate the flag
88 -- Raises_Constraint_Error to the result node and we are done (since the
89 -- error was already posted at a lower level).
91 -- For the case of a static node whose operands do not raise constraint
92 -- error, we attempt to evaluate the node. If this evaluation succeeds,
93 -- then the node is replaced by the result of this computation. If the
94 -- evaluation raises constraint error, then we rewrite the node with
95 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
96 -- to post appropriate error messages.
102 type Bits is array (Nat range <>) of Boolean;
103 -- Used to convert unsigned (modular) values for folding logical ops
105 -- The following declarations are used to maintain a cache of nodes that
106 -- have compile time known values. The cache is maintained only for
107 -- discrete types (the most common case), and is populated by calls to
108 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
109 -- since it is possible for the status to change (in particular it is
110 -- possible for a node to get replaced by a constraint error node).
112 CV_Bits : constant := 5;
113 -- Number of low order bits of Node_Id value used to reference entries
114 -- in the cache table.
116 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
117 -- Size of cache for compile time values
119 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
121 type CV_Entry is record
126 type CV_Cache_Array is array (CV_Range) of CV_Entry;
128 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
129 -- This is the actual cache, with entries consisting of node/value pairs,
130 -- and the impossible value Node_High_Bound used for unset entries.
132 type Range_Membership is (In_Range, Out_Of_Range, Unknown);
133 -- Range membership may either be statically known to be in range or out
134 -- of range, or not statically known. Used for Test_In_Range below.
136 -----------------------
137 -- Local Subprograms --
138 -----------------------
140 function From_Bits (B : Bits; T : Entity_Id) return Uint;
141 -- Converts a bit string of length B'Length to a Uint value to be used for
142 -- a target of type T, which is a modular type. This procedure includes the
143 -- necessary reduction by the modulus in the case of a non-binary modulus
144 -- (for a binary modulus, the bit string is the right length any way so all
147 function Get_String_Val (N : Node_Id) return Node_Id;
148 -- Given a tree node for a folded string or character value, returns the
149 -- corresponding string literal or character literal (one of the two must
150 -- be available, or the operand would not have been marked as foldable in
151 -- the earlier analysis of the operation).
153 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
154 -- Bits represents the number of bits in an integer value to be computed
155 -- (but the value has not been computed yet). If this value in Bits is
156 -- reasonable, a result of True is returned, with the implication that the
157 -- caller should go ahead and complete the calculation. If the value in
158 -- Bits is unreasonably large, then an error is posted on node N, and
159 -- False is returned (and the caller skips the proposed calculation).
161 procedure Out_Of_Range (N : Node_Id);
162 -- This procedure is called if it is determined that node N, which appears
163 -- in a non-static context, is a compile time known value which is outside
164 -- its range, i.e. the range of Etype. This is used in contexts where
165 -- this is an illegality if N is static, and should generate a warning
168 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
169 -- N and Exp are nodes representing an expression, Exp is known to raise
170 -- CE. N is rewritten in term of Exp in the optimal way.
172 function String_Type_Len (Stype : Entity_Id) return Uint;
173 -- Given a string type, determines the length of the index type, or, if
174 -- this index type is non-static, the length of the base type of this index
175 -- type. Note that if the string type is itself static, then the index type
176 -- is static, so the second case applies only if the string type passed is
179 function Test (Cond : Boolean) return Uint;
180 pragma Inline (Test);
181 -- This function simply returns the appropriate Boolean'Pos value
182 -- corresponding to the value of Cond as a universal integer. It is
183 -- used for producing the result of the static evaluation of the
186 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
187 -- Check whether an arithmetic operation with universal operands which is a
188 -- rewritten function call with an explicit scope indication is ambiguous:
189 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
190 -- type declared in P and the context does not impose a type on the result
191 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
192 -- error and return Empty, else return the result type of the operator.
194 procedure Test_Expression_Is_Foldable
199 -- Tests to see if expression N whose single operand is Op1 is foldable,
200 -- i.e. the operand value is known at compile time. If the operation is
201 -- foldable, then Fold is True on return, and Stat indicates whether the
202 -- result is static (i.e. the operand was static). Note that it is quite
203 -- possible for Fold to be True, and Stat to be False, since there are
204 -- cases in which we know the value of an operand even though it is not
205 -- technically static (e.g. the static lower bound of a range whose upper
206 -- bound is non-static).
208 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
209 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
210 -- return, then all processing is complete, and the caller should return,
211 -- since there is nothing else to do.
213 -- If Stat is set True on return, then Is_Static_Expression is also set
214 -- true in node N. There are some cases where this is over-enthusiastic,
215 -- e.g. in the two operand case below, for string comparison, the result is
216 -- not static even though the two operands are static. In such cases, the
217 -- caller must reset the Is_Static_Expression flag in N.
219 -- If Fold and Stat are both set to False then this routine performs also
220 -- the following extra actions:
222 -- If either operand is Any_Type then propagate it to result to prevent
225 -- If some operand raises constraint error, then replace the node N
226 -- with the raise constraint error node. This replacement inherits the
227 -- Is_Static_Expression flag from the operands.
229 procedure Test_Expression_Is_Foldable
235 CRT_Safe : Boolean := False);
236 -- Same processing, except applies to an expression N with two operands
237 -- Op1 and Op2. The result is static only if both operands are static. If
238 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
239 -- for the tests that the two operands are known at compile time. See
240 -- spec of this routine for further details.
242 function Test_In_Range
245 Assume_Valid : Boolean;
247 Int_Real : Boolean) return Range_Membership;
248 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
249 -- or Out_Of_Range if it can be guaranteed at compile time that expression
250 -- N is known to be in or out of range of the subtype Typ. If not compile
251 -- time known, Unknown is returned. See documentation of Is_In_Range for
252 -- complete description of parameters.
254 procedure To_Bits (U : Uint; B : out Bits);
255 -- Converts a Uint value to a bit string of length B'Length
257 ------------------------------
258 -- Check_Non_Static_Context --
259 ------------------------------
261 procedure Check_Non_Static_Context (N : Node_Id) is
262 T : constant Entity_Id := Etype (N);
263 Checks_On : constant Boolean :=
264 not Index_Checks_Suppressed (T)
265 and not Range_Checks_Suppressed (T);
268 -- Ignore cases of non-scalar types, error types, or universal real
269 -- types that have no usable bounds.
272 or else not Is_Scalar_Type (T)
273 or else T = Universal_Fixed
274 or else T = Universal_Real
279 -- At this stage we have a scalar type. If we have an expression that
280 -- raises CE, then we already issued a warning or error msg so there is
281 -- nothing more to be done in this routine.
283 if Raises_Constraint_Error (N) then
287 -- Now we have a scalar type which is not marked as raising a constraint
288 -- error exception. The main purpose of this routine is to deal with
289 -- static expressions appearing in a non-static context. That means
290 -- that if we do not have a static expression then there is not much
291 -- to do. The one case that we deal with here is that if we have a
292 -- floating-point value that is out of range, then we post a warning
293 -- that an infinity will result.
295 if not Is_Static_Expression (N) then
296 if Is_Floating_Point_Type (T)
297 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
300 ("??float value out of range, infinity will be generated", N);
306 -- Here we have the case of outer level static expression of scalar
307 -- type, where the processing of this procedure is needed.
309 -- For real types, this is where we convert the value to a machine
310 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
311 -- need to do this if the parent is a constant declaration, since in
312 -- other cases, gigi should do the necessary conversion correctly, but
313 -- experimentation shows that this is not the case on all machines, in
314 -- particular if we do not convert all literals to machine values in
315 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
318 if Nkind (N) = N_Real_Literal
319 and then not Is_Machine_Number (N)
320 and then not Is_Generic_Type (Etype (N))
321 and then Etype (N) /= Universal_Real
323 -- Check that value is in bounds before converting to machine
324 -- number, so as not to lose case where value overflows in the
325 -- least significant bit or less. See B490001.
327 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
332 -- Note: we have to copy the node, to avoid problems with conformance
333 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
335 Rewrite (N, New_Copy (N));
337 if not Is_Floating_Point_Type (T) then
339 (N, Corresponding_Integer_Value (N) * Small_Value (T));
341 elsif not UR_Is_Zero (Realval (N)) then
343 -- Note: even though RM 4.9(38) specifies biased rounding, this
344 -- has been modified by AI-100 in order to prevent confusing
345 -- differences in rounding between static and non-static
346 -- expressions. AI-100 specifies that the effect of such rounding
347 -- is implementation dependent, and in GNAT we round to nearest
348 -- even to match the run-time behavior.
351 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
354 Set_Is_Machine_Number (N);
357 -- Check for out of range universal integer. This is a non-static
358 -- context, so the integer value must be in range of the runtime
359 -- representation of universal integers.
361 -- We do this only within an expression, because that is the only
362 -- case in which non-static universal integer values can occur, and
363 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
364 -- called in contexts like the expression of a number declaration where
365 -- we certainly want to allow out of range values.
367 if Etype (N) = Universal_Integer
368 and then Nkind (N) = N_Integer_Literal
369 and then Nkind (Parent (N)) in N_Subexpr
371 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
373 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
375 Apply_Compile_Time_Constraint_Error
376 (N, "non-static universal integer value out of range<<",
377 CE_Range_Check_Failed);
379 -- Check out of range of base type
381 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
384 -- Give warning if outside subtype (where one or both of the bounds of
385 -- the subtype is static). This warning is omitted if the expression
386 -- appears in a range that could be null (warnings are handled elsewhere
389 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
390 if Is_In_Range (N, T, Assume_Valid => True) then
393 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
394 Apply_Compile_Time_Constraint_Error
395 (N, "value not in range of}<<", CE_Range_Check_Failed);
398 Enable_Range_Check (N);
401 Set_Do_Range_Check (N, False);
404 end Check_Non_Static_Context;
406 ---------------------------------
407 -- Check_String_Literal_Length --
408 ---------------------------------
410 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
412 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
413 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
415 Apply_Compile_Time_Constraint_Error
416 (N, "string length wrong for}??",
417 CE_Length_Check_Failed,
422 end Check_String_Literal_Length;
424 --------------------------
425 -- Compile_Time_Compare --
426 --------------------------
428 function Compile_Time_Compare
430 Assume_Valid : Boolean) return Compare_Result
432 Discard : aliased Uint;
434 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
435 end Compile_Time_Compare;
437 function Compile_Time_Compare
440 Assume_Valid : Boolean;
441 Rec : Boolean := False) return Compare_Result
443 Ltyp : Entity_Id := Underlying_Type (Etype (L));
444 Rtyp : Entity_Id := Underlying_Type (Etype (R));
445 -- These get reset to the base type for the case of entities where
446 -- Is_Known_Valid is not set. This takes care of handling possible
447 -- invalid representations using the value of the base type, in
448 -- accordance with RM 13.9.1(10).
450 Discard : aliased Uint;
452 procedure Compare_Decompose
456 -- This procedure decomposes the node N into an expression node and a
457 -- signed offset, so that the value of N is equal to the value of R plus
458 -- the value V (which may be negative). If no such decomposition is
459 -- possible, then on return R is a copy of N, and V is set to zero.
461 function Compare_Fixup (N : Node_Id) return Node_Id;
462 -- This function deals with replacing 'Last and 'First references with
463 -- their corresponding type bounds, which we then can compare. The
464 -- argument is the original node, the result is the identity, unless we
465 -- have a 'Last/'First reference in which case the value returned is the
466 -- appropriate type bound.
468 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
469 -- Even if the context does not assume that values are valid, some
470 -- simple cases can be recognized.
472 function Is_Same_Value (L, R : Node_Id) return Boolean;
473 -- Returns True iff L and R represent expressions that definitely have
474 -- identical (but not necessarily compile time known) values Indeed the
475 -- caller is expected to have already dealt with the cases of compile
476 -- time known values, so these are not tested here.
478 -----------------------
479 -- Compare_Decompose --
480 -----------------------
482 procedure Compare_Decompose
488 if Nkind (N) = N_Op_Add
489 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
492 V := Intval (Right_Opnd (N));
495 elsif Nkind (N) = N_Op_Subtract
496 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
499 V := UI_Negate (Intval (Right_Opnd (N)));
502 elsif Nkind (N) = N_Attribute_Reference then
503 if Attribute_Name (N) = Name_Succ then
504 R := First (Expressions (N));
508 elsif Attribute_Name (N) = Name_Pred then
509 R := First (Expressions (N));
517 end Compare_Decompose;
523 function Compare_Fixup (N : Node_Id) return Node_Id is
529 -- Fixup only required for First/Last attribute reference
531 if Nkind (N) = N_Attribute_Reference
532 and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
534 Xtyp := Etype (Prefix (N));
536 -- If we have no type, then just abandon the attempt to do
537 -- a fixup, this is probably the result of some other error.
543 -- Dereference an access type
545 if Is_Access_Type (Xtyp) then
546 Xtyp := Designated_Type (Xtyp);
549 -- If we don't have an array type at this stage, something is
550 -- peculiar, e.g. another error, and we abandon the attempt at
553 if not Is_Array_Type (Xtyp) then
557 -- Ignore unconstrained array, since bounds are not meaningful
559 if not Is_Constrained (Xtyp) then
563 if Ekind (Xtyp) = E_String_Literal_Subtype then
564 if Attribute_Name (N) = Name_First then
565 return String_Literal_Low_Bound (Xtyp);
568 Make_Integer_Literal (Sloc (N),
569 Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
570 String_Literal_Length (Xtyp));
574 -- Find correct index type
576 Indx := First_Index (Xtyp);
578 if Present (Expressions (N)) then
579 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
581 for J in 2 .. Subs loop
582 Indx := Next_Index (Indx);
586 Xtyp := Etype (Indx);
588 if Attribute_Name (N) = Name_First then
589 return Type_Low_Bound (Xtyp);
591 return Type_High_Bound (Xtyp);
598 ----------------------------
599 -- Is_Known_Valid_Operand --
600 ----------------------------
602 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
604 return (Is_Entity_Name (Opnd)
606 (Is_Known_Valid (Entity (Opnd))
607 or else Ekind (Entity (Opnd)) = E_In_Parameter
609 (Ekind (Entity (Opnd)) in Object_Kind
610 and then Present (Current_Value (Entity (Opnd))))))
611 or else Is_OK_Static_Expression (Opnd);
612 end Is_Known_Valid_Operand;
618 function Is_Same_Value (L, R : Node_Id) return Boolean is
619 Lf : constant Node_Id := Compare_Fixup (L);
620 Rf : constant Node_Id := Compare_Fixup (R);
622 function Is_Same_Subscript (L, R : List_Id) return Boolean;
623 -- L, R are the Expressions values from two attribute nodes for First
624 -- or Last attributes. Either may be set to No_List if no expressions
625 -- are present (indicating subscript 1). The result is True if both
626 -- expressions represent the same subscript (note one case is where
627 -- one subscript is missing and the other is explicitly set to 1).
629 -----------------------
630 -- Is_Same_Subscript --
631 -----------------------
633 function Is_Same_Subscript (L, R : List_Id) return Boolean is
639 return Expr_Value (First (R)) = Uint_1;
644 return Expr_Value (First (L)) = Uint_1;
646 return Expr_Value (First (L)) = Expr_Value (First (R));
649 end Is_Same_Subscript;
651 -- Start of processing for Is_Same_Value
654 -- Values are the same if they refer to the same entity and the
655 -- entity is non-volatile. This does not however apply to Float
656 -- types, since we may have two NaN values and they should never
659 -- If the entity is a discriminant, the two expressions may be bounds
660 -- of components of objects of the same discriminated type. The
661 -- values of the discriminants are not static, and therefore the
662 -- result is unknown.
664 -- It would be better to comment individual branches of this test ???
666 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
667 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
668 and then Entity (Lf) = Entity (Rf)
669 and then Ekind (Entity (Lf)) /= E_Discriminant
670 and then Present (Entity (Lf))
671 and then not Is_Floating_Point_Type (Etype (L))
672 and then not Is_Volatile_Reference (L)
673 and then not Is_Volatile_Reference (R)
677 -- Or if they are compile time known and identical
679 elsif Compile_Time_Known_Value (Lf)
681 Compile_Time_Known_Value (Rf)
682 and then Expr_Value (Lf) = Expr_Value (Rf)
686 -- False if Nkind of the two nodes is different for remaining cases
688 elsif Nkind (Lf) /= Nkind (Rf) then
691 -- True if both 'First or 'Last values applying to the same entity
692 -- (first and last don't change even if value does). Note that we
693 -- need this even with the calls to Compare_Fixup, to handle the
694 -- case of unconstrained array attributes where Compare_Fixup
695 -- cannot find useful bounds.
697 elsif Nkind (Lf) = N_Attribute_Reference
698 and then Attribute_Name (Lf) = Attribute_Name (Rf)
699 and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
700 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
701 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
702 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
703 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
707 -- True if the same selected component from the same record
709 elsif Nkind (Lf) = N_Selected_Component
710 and then Selector_Name (Lf) = Selector_Name (Rf)
711 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
715 -- True if the same unary operator applied to the same operand
717 elsif Nkind (Lf) in N_Unary_Op
718 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
722 -- True if the same binary operator applied to the same operands
724 elsif Nkind (Lf) in N_Binary_Op
725 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
726 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
730 -- All other cases, we can't tell, so return False
737 -- Start of processing for Compile_Time_Compare
742 -- In preanalysis mode, always return Unknown unless the expression
743 -- is static. It is too early to be thinking we know the result of a
744 -- comparison, save that judgment for the full analysis. This is
745 -- particularly important in the case of pre and postconditions, which
746 -- otherwise can be prematurely collapsed into having True or False
747 -- conditions when this is inappropriate.
749 if not (Full_Analysis
750 or else (Is_Static_Expression (L)
752 Is_Static_Expression (R)))
757 -- If either operand could raise constraint error, then we cannot
758 -- know the result at compile time (since CE may be raised).
760 if not (Cannot_Raise_Constraint_Error (L)
762 Cannot_Raise_Constraint_Error (R))
767 -- Identical operands are most certainly equal
772 -- If expressions have no types, then do not attempt to determine if
773 -- they are the same, since something funny is going on. One case in
774 -- which this happens is during generic template analysis, when bounds
775 -- are not fully analyzed.
777 elsif No (Ltyp) or else No (Rtyp) then
780 -- We do not attempt comparisons for packed arrays arrays represented as
781 -- modular types, where the semantics of comparison is quite different.
783 elsif Is_Packed_Array_Impl_Type (Ltyp)
784 and then Is_Modular_Integer_Type (Ltyp)
788 -- For access types, the only time we know the result at compile time
789 -- (apart from identical operands, which we handled already) is if we
790 -- know one operand is null and the other is not, or both operands are
793 elsif Is_Access_Type (Ltyp) then
794 if Known_Null (L) then
795 if Known_Null (R) then
797 elsif Known_Non_Null (R) then
803 elsif Known_Non_Null (L) and then Known_Null (R) then
810 -- Case where comparison involves two compile time known values
812 elsif Compile_Time_Known_Value (L)
814 Compile_Time_Known_Value (R)
816 -- For the floating-point case, we have to be a little careful, since
817 -- at compile time we are dealing with universal exact values, but at
818 -- runtime, these will be in non-exact target form. That's why the
819 -- returned results are LE and GE below instead of LT and GT.
821 if Is_Floating_Point_Type (Ltyp)
823 Is_Floating_Point_Type (Rtyp)
826 Lo : constant Ureal := Expr_Value_R (L);
827 Hi : constant Ureal := Expr_Value_R (R);
838 -- For string types, we have two string literals and we proceed to
839 -- compare them using the Ada style dictionary string comparison.
841 elsif not Is_Scalar_Type (Ltyp) then
843 Lstring : constant String_Id := Strval (Expr_Value_S (L));
844 Rstring : constant String_Id := Strval (Expr_Value_S (R));
845 Llen : constant Nat := String_Length (Lstring);
846 Rlen : constant Nat := String_Length (Rstring);
849 for J in 1 .. Nat'Min (Llen, Rlen) loop
851 LC : constant Char_Code := Get_String_Char (Lstring, J);
852 RC : constant Char_Code := Get_String_Char (Rstring, J);
864 elsif Llen > Rlen then
871 -- For remaining scalar cases we know exactly (note that this does
872 -- include the fixed-point case, where we know the run time integer
877 Lo : constant Uint := Expr_Value (L);
878 Hi : constant Uint := Expr_Value (R);
892 -- Cases where at least one operand is not known at compile time
895 -- Remaining checks apply only for discrete types
897 if not Is_Discrete_Type (Ltyp)
899 not Is_Discrete_Type (Rtyp)
904 -- Defend against generic types, or actually any expressions that
905 -- contain a reference to a generic type from within a generic
906 -- template. We don't want to do any range analysis of such
907 -- expressions for two reasons. First, the bounds of a generic type
908 -- itself are junk and cannot be used for any kind of analysis.
909 -- Second, we may have a case where the range at run time is indeed
910 -- known, but we don't want to do compile time analysis in the
911 -- template based on that range since in an instance the value may be
912 -- static, and able to be elaborated without reference to the bounds
913 -- of types involved. As an example, consider:
915 -- (F'Pos (F'Last) + 1) > Integer'Last
917 -- The expression on the left side of > is Universal_Integer and thus
918 -- acquires the type Integer for evaluation at run time, and at run
919 -- time it is true that this condition is always False, but within
920 -- an instance F may be a type with a static range greater than the
921 -- range of Integer, and the expression statically evaluates to True.
923 if References_Generic_Formal_Type (L)
925 References_Generic_Formal_Type (R)
930 -- Replace types by base types for the case of entities which are not
931 -- known to have valid representations. This takes care of properly
932 -- dealing with invalid representations.
934 if not Assume_Valid and then not Assume_No_Invalid_Values then
935 if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
936 Ltyp := Underlying_Type (Base_Type (Ltyp));
939 if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
940 Rtyp := Underlying_Type (Base_Type (Rtyp));
944 -- First attempt is to decompose the expressions to extract a
945 -- constant offset resulting from the use of any of the forms:
952 -- Then we see if the two expressions are the same value, and if so
953 -- the result is obtained by comparing the offsets.
955 -- Note: the reason we do this test first is that it returns only
956 -- decisive results (with diff set), where other tests, like the
957 -- range test, may not be as so decisive. Consider for example
958 -- J .. J + 1. This code can conclude LT with a difference of 1,
959 -- even if the range of J is not known.
968 Compare_Decompose (L, Lnode, Loffs);
969 Compare_Decompose (R, Rnode, Roffs);
971 if Is_Same_Value (Lnode, Rnode) then
972 if Loffs = Roffs then
974 elsif Loffs < Roffs then
975 Diff.all := Roffs - Loffs;
978 Diff.all := Loffs - Roffs;
984 -- Next, try range analysis and see if operand ranges are disjoint
992 -- True if each range is a single point
995 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
996 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
999 Single := (LLo = LHi) and then (RLo = RHi);
1002 if Single and Assume_Valid then
1003 Diff.all := RLo - LLo;
1008 elsif RHi < LLo then
1009 if Single and Assume_Valid then
1010 Diff.all := LLo - RLo;
1015 elsif Single and then LLo = RLo then
1017 -- If the range includes a single literal and we can assume
1018 -- validity then the result is known even if an operand is
1021 if Assume_Valid then
1027 elsif LHi = RLo then
1030 elsif RHi = LLo then
1033 elsif not Is_Known_Valid_Operand (L)
1034 and then not Assume_Valid
1036 if Is_Same_Value (L, R) then
1043 -- If the range of either operand cannot be determined, nothing
1044 -- further can be inferred.
1051 -- Here is where we check for comparisons against maximum bounds of
1052 -- types, where we know that no value can be outside the bounds of
1053 -- the subtype. Note that this routine is allowed to assume that all
1054 -- expressions are within their subtype bounds. Callers wishing to
1055 -- deal with possibly invalid values must in any case take special
1056 -- steps (e.g. conversions to larger types) to avoid this kind of
1057 -- optimization, which is always considered to be valid. We do not
1058 -- attempt this optimization with generic types, since the type
1059 -- bounds may not be meaningful in this case.
1061 -- We are in danger of an infinite recursion here. It does not seem
1062 -- useful to go more than one level deep, so the parameter Rec is
1063 -- used to protect ourselves against this infinite recursion.
1067 -- See if we can get a decisive check against one operand and a
1068 -- bound of the other operand (four possible tests here). Note
1069 -- that we avoid testing junk bounds of a generic type.
1071 if not Is_Generic_Type (Rtyp) then
1072 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1074 Assume_Valid, Rec => True)
1076 when LT => return LT;
1077 when LE => return LE;
1078 when EQ => return LE;
1079 when others => null;
1082 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1084 Assume_Valid, Rec => True)
1086 when GT => return GT;
1087 when GE => return GE;
1088 when EQ => return GE;
1089 when others => null;
1093 if not Is_Generic_Type (Ltyp) then
1094 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1096 Assume_Valid, Rec => True)
1098 when GT => return GT;
1099 when GE => return GE;
1100 when EQ => return GE;
1101 when others => null;
1104 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1106 Assume_Valid, Rec => True)
1108 when LT => return LT;
1109 when LE => return LE;
1110 when EQ => return LE;
1111 when others => null;
1116 -- Next attempt is to see if we have an entity compared with a
1117 -- compile time known value, where there is a current value
1118 -- conditional for the entity which can tell us the result.
1122 -- Entity variable (left operand)
1125 -- Value (right operand)
1128 -- If False, we have reversed the operands
1131 -- Comparison operator kind from Get_Current_Value_Condition call
1134 -- Value from Get_Current_Value_Condition call
1139 Result : Compare_Result;
1140 -- Known result before inversion
1143 if Is_Entity_Name (L)
1144 and then Compile_Time_Known_Value (R)
1147 Val := Expr_Value (R);
1150 elsif Is_Entity_Name (R)
1151 and then Compile_Time_Known_Value (L)
1154 Val := Expr_Value (L);
1157 -- That was the last chance at finding a compile time result
1163 Get_Current_Value_Condition (Var, Op, Opn);
1165 -- That was the last chance, so if we got nothing return
1171 Opv := Expr_Value (Opn);
1173 -- We got a comparison, so we might have something interesting
1175 -- Convert LE to LT and GE to GT, just so we have fewer cases
1177 if Op = N_Op_Le then
1181 elsif Op = N_Op_Ge then
1186 -- Deal with equality case
1188 if Op = N_Op_Eq then
1191 elsif Opv < Val then
1197 -- Deal with inequality case
1199 elsif Op = N_Op_Ne then
1206 -- Deal with greater than case
1208 elsif Op = N_Op_Gt then
1211 elsif Opv = Val - 1 then
1217 -- Deal with less than case
1219 else pragma Assert (Op = N_Op_Lt);
1222 elsif Opv = Val + 1 then
1229 -- Deal with inverting result
1233 when GT => return LT;
1234 when GE => return LE;
1235 when LT => return GT;
1236 when LE => return GE;
1237 when others => return Result;
1244 end Compile_Time_Compare;
1246 -------------------------------
1247 -- Compile_Time_Known_Bounds --
1248 -------------------------------
1250 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1255 if T = Any_Composite or else not Is_Array_Type (T) then
1259 Indx := First_Index (T);
1260 while Present (Indx) loop
1261 Typ := Underlying_Type (Etype (Indx));
1263 -- Never look at junk bounds of a generic type
1265 if Is_Generic_Type (Typ) then
1269 -- Otherwise check bounds for compile time known
1271 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1273 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1281 end Compile_Time_Known_Bounds;
1283 ------------------------------
1284 -- Compile_Time_Known_Value --
1285 ------------------------------
1287 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1288 K : constant Node_Kind := Nkind (Op);
1289 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1292 -- Never known at compile time if bad type or raises constraint error
1293 -- or empty (latter case occurs only as a result of a previous error).
1296 Check_Error_Detected;
1300 or else Etype (Op) = Any_Type
1301 or else Raises_Constraint_Error (Op)
1306 -- If we have an entity name, then see if it is the name of a constant
1307 -- and if so, test the corresponding constant value, or the name of
1308 -- an enumeration literal, which is always a constant.
1310 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1312 E : constant Entity_Id := Entity (Op);
1316 -- Never known at compile time if it is a packed array value.
1317 -- We might want to try to evaluate these at compile time one
1318 -- day, but we do not make that attempt now.
1320 if Is_Packed_Array_Impl_Type (Etype (Op)) then
1324 if Ekind (E) = E_Enumeration_Literal then
1327 elsif Ekind (E) = E_Constant then
1328 V := Constant_Value (E);
1329 return Present (V) and then Compile_Time_Known_Value (V);
1333 -- We have a value, see if it is compile time known
1336 -- Integer literals are worth storing in the cache
1338 if K = N_Integer_Literal then
1340 CV_Ent.V := Intval (Op);
1343 -- Other literals and NULL are known at compile time
1346 Nkind_In (K, N_Character_Literal,
1353 -- Any reference to Null_Parameter is known at compile time. No
1354 -- other attribute references (that have not already been folded)
1355 -- are known at compile time.
1357 elsif K = N_Attribute_Reference then
1358 return Attribute_Name (Op) = Name_Null_Parameter;
1362 -- If we fall through, not known at compile time
1366 -- If we get an exception while trying to do this test, then some error
1367 -- has occurred, and we simply say that the value is not known after all
1372 end Compile_Time_Known_Value;
1374 --------------------------------------
1375 -- Compile_Time_Known_Value_Or_Aggr --
1376 --------------------------------------
1378 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1380 -- If we have an entity name, then see if it is the name of a constant
1381 -- and if so, test the corresponding constant value, or the name of
1382 -- an enumeration literal, which is always a constant.
1384 if Is_Entity_Name (Op) then
1386 E : constant Entity_Id := Entity (Op);
1390 if Ekind (E) = E_Enumeration_Literal then
1393 elsif Ekind (E) /= E_Constant then
1397 V := Constant_Value (E);
1399 and then Compile_Time_Known_Value_Or_Aggr (V);
1403 -- We have a value, see if it is compile time known
1406 if Compile_Time_Known_Value (Op) then
1409 elsif Nkind (Op) = N_Aggregate then
1411 if Present (Expressions (Op)) then
1415 Expr := First (Expressions (Op));
1416 while Present (Expr) loop
1417 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1426 if Present (Component_Associations (Op)) then
1431 Cass := First (Component_Associations (Op));
1432 while Present (Cass) loop
1434 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1446 -- All other types of values are not known at compile time
1453 end Compile_Time_Known_Value_Or_Aggr;
1455 ---------------------------------------
1456 -- CRT_Safe_Compile_Time_Known_Value --
1457 ---------------------------------------
1459 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1461 if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
1462 and then not Is_OK_Static_Expression (Op)
1466 return Compile_Time_Known_Value (Op);
1468 end CRT_Safe_Compile_Time_Known_Value;
1474 -- This is only called for actuals of functions that are not predefined
1475 -- operators (which have already been rewritten as operators at this
1476 -- stage), so the call can never be folded, and all that needs doing for
1477 -- the actual is to do the check for a non-static context.
1479 procedure Eval_Actual (N : Node_Id) is
1481 Check_Non_Static_Context (N);
1484 --------------------
1485 -- Eval_Allocator --
1486 --------------------
1488 -- Allocators are never static, so all we have to do is to do the
1489 -- check for a non-static context if an expression is present.
1491 procedure Eval_Allocator (N : Node_Id) is
1492 Expr : constant Node_Id := Expression (N);
1494 if Nkind (Expr) = N_Qualified_Expression then
1495 Check_Non_Static_Context (Expression (Expr));
1499 ------------------------
1500 -- Eval_Arithmetic_Op --
1501 ------------------------
1503 -- Arithmetic operations are static functions, so the result is static
1504 -- if both operands are static (RM 4.9(7), 4.9(20)).
1506 procedure Eval_Arithmetic_Op (N : Node_Id) is
1507 Left : constant Node_Id := Left_Opnd (N);
1508 Right : constant Node_Id := Right_Opnd (N);
1509 Ltype : constant Entity_Id := Etype (Left);
1510 Rtype : constant Entity_Id := Etype (Right);
1511 Otype : Entity_Id := Empty;
1516 -- If not foldable we are done
1518 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1524 -- Otherwise attempt to fold
1526 if Is_Universal_Numeric_Type (Etype (Left))
1528 Is_Universal_Numeric_Type (Etype (Right))
1530 Otype := Find_Universal_Operator_Type (N);
1533 -- Fold for cases where both operands are of integer type
1535 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1537 Left_Int : constant Uint := Expr_Value (Left);
1538 Right_Int : constant Uint := Expr_Value (Right);
1544 Result := Left_Int + Right_Int;
1546 when N_Op_Subtract =>
1547 Result := Left_Int - Right_Int;
1549 when N_Op_Multiply =>
1552 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1554 Result := Left_Int * Right_Int;
1561 -- The exception Constraint_Error is raised by integer
1562 -- division, rem and mod if the right operand is zero.
1564 if Right_Int = 0 then
1565 Apply_Compile_Time_Constraint_Error
1566 (N, "division by zero", CE_Divide_By_Zero,
1571 Result := Left_Int / Right_Int;
1576 -- The exception Constraint_Error is raised by integer
1577 -- division, rem and mod if the right operand is zero.
1579 if Right_Int = 0 then
1580 Apply_Compile_Time_Constraint_Error
1581 (N, "mod with zero divisor", CE_Divide_By_Zero,
1585 Result := Left_Int mod Right_Int;
1590 -- The exception Constraint_Error is raised by integer
1591 -- division, rem and mod if the right operand is zero.
1593 if Right_Int = 0 then
1594 Apply_Compile_Time_Constraint_Error
1595 (N, "rem with zero divisor", CE_Divide_By_Zero,
1600 Result := Left_Int rem Right_Int;
1604 raise Program_Error;
1607 -- Adjust the result by the modulus if the type is a modular type
1609 if Is_Modular_Integer_Type (Ltype) then
1610 Result := Result mod Modulus (Ltype);
1612 -- For a signed integer type, check non-static overflow
1614 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1616 BT : constant Entity_Id := Base_Type (Ltype);
1617 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1618 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1620 if Result < Lo or else Result > Hi then
1621 Apply_Compile_Time_Constraint_Error
1622 (N, "value not in range of }??",
1623 CE_Overflow_Check_Failed,
1630 -- If we get here we can fold the result
1632 Fold_Uint (N, Result, Stat);
1635 -- Cases where at least one operand is a real. We handle the cases of
1636 -- both reals, or mixed/real integer cases (the latter happen only for
1637 -- divide and multiply, and the result is always real).
1639 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1646 if Is_Real_Type (Ltype) then
1647 Left_Real := Expr_Value_R (Left);
1649 Left_Real := UR_From_Uint (Expr_Value (Left));
1652 if Is_Real_Type (Rtype) then
1653 Right_Real := Expr_Value_R (Right);
1655 Right_Real := UR_From_Uint (Expr_Value (Right));
1658 if Nkind (N) = N_Op_Add then
1659 Result := Left_Real + Right_Real;
1661 elsif Nkind (N) = N_Op_Subtract then
1662 Result := Left_Real - Right_Real;
1664 elsif Nkind (N) = N_Op_Multiply then
1665 Result := Left_Real * Right_Real;
1667 else pragma Assert (Nkind (N) = N_Op_Divide);
1668 if UR_Is_Zero (Right_Real) then
1669 Apply_Compile_Time_Constraint_Error
1670 (N, "division by zero", CE_Divide_By_Zero);
1674 Result := Left_Real / Right_Real;
1677 Fold_Ureal (N, Result, Stat);
1681 -- If the operator was resolved to a specific type, make sure that type
1682 -- is frozen even if the expression is folded into a literal (which has
1683 -- a universal type).
1685 if Present (Otype) then
1686 Freeze_Before (N, Otype);
1688 end Eval_Arithmetic_Op;
1690 ----------------------------
1691 -- Eval_Character_Literal --
1692 ----------------------------
1694 -- Nothing to be done
1696 procedure Eval_Character_Literal (N : Node_Id) is
1697 pragma Warnings (Off, N);
1700 end Eval_Character_Literal;
1706 -- Static function calls are either calls to predefined operators
1707 -- with static arguments, or calls to functions that rename a literal.
1708 -- Only the latter case is handled here, predefined operators are
1709 -- constant-folded elsewhere.
1711 -- If the function is itself inherited (see 7423-001) the literal of
1712 -- the parent type must be explicitly converted to the return type
1715 procedure Eval_Call (N : Node_Id) is
1716 Loc : constant Source_Ptr := Sloc (N);
1717 Typ : constant Entity_Id := Etype (N);
1721 if Nkind (N) = N_Function_Call
1722 and then No (Parameter_Associations (N))
1723 and then Is_Entity_Name (Name (N))
1724 and then Present (Alias (Entity (Name (N))))
1725 and then Is_Enumeration_Type (Base_Type (Typ))
1727 Lit := Ultimate_Alias (Entity (Name (N)));
1729 if Ekind (Lit) = E_Enumeration_Literal then
1730 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
1732 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
1734 Rewrite (N, New_Occurrence_Of (Lit, Loc));
1742 --------------------------
1743 -- Eval_Case_Expression --
1744 --------------------------
1746 -- A conditional expression is static if all its conditions and dependent
1747 -- expressions are static.
1749 procedure Eval_Case_Expression (N : Node_Id) is
1752 Is_Static : Boolean;
1760 if Is_Static_Expression (Expression (N)) then
1761 Val := Expr_Value (Expression (N));
1763 Check_Non_Static_Context (Expression (N));
1767 Alt := First (Alternatives (N));
1769 Search : while Present (Alt) loop
1771 or else not Is_Static_Expression (Expression (Alt))
1773 Check_Non_Static_Context (Expression (Alt));
1777 Choice := First (Discrete_Choices (Alt));
1778 while Present (Choice) loop
1779 if Nkind (Choice) = N_Others_Choice then
1780 Result := Expression (Alt);
1783 elsif Expr_Value (Choice) = Val then
1784 Result := Expression (Alt);
1797 Rewrite (N, Relocate_Node (Result));
1800 Set_Is_Static_Expression (N, False);
1802 end Eval_Case_Expression;
1804 ------------------------
1805 -- Eval_Concatenation --
1806 ------------------------
1808 -- Concatenation is a static function, so the result is static if both
1809 -- operands are static (RM 4.9(7), 4.9(21)).
1811 procedure Eval_Concatenation (N : Node_Id) is
1812 Left : constant Node_Id := Left_Opnd (N);
1813 Right : constant Node_Id := Right_Opnd (N);
1814 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
1819 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
1820 -- non-static context.
1822 if Ada_Version = Ada_83
1823 and then Comes_From_Source (N)
1825 Check_Non_Static_Context (Left);
1826 Check_Non_Static_Context (Right);
1830 -- If not foldable we are done. In principle concatenation that yields
1831 -- any string type is static (i.e. an array type of character types).
1832 -- However, character types can include enumeration literals, and
1833 -- concatenation in that case cannot be described by a literal, so we
1834 -- only consider the operation static if the result is an array of
1835 -- (a descendant of) a predefined character type.
1837 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1839 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
1840 Set_Is_Static_Expression (N, False);
1844 -- Compile time string concatenation
1846 -- ??? Note that operands that are aggregates can be marked as static,
1847 -- so we should attempt at a later stage to fold concatenations with
1851 Left_Str : constant Node_Id := Get_String_Val (Left);
1853 Right_Str : constant Node_Id := Get_String_Val (Right);
1854 Folded_Val : String_Id;
1857 -- Establish new string literal, and store left operand. We make
1858 -- sure to use the special Start_String that takes an operand if
1859 -- the left operand is a string literal. Since this is optimized
1860 -- in the case where that is the most recently created string
1861 -- literal, we ensure efficient time/space behavior for the
1862 -- case of a concatenation of a series of string literals.
1864 if Nkind (Left_Str) = N_String_Literal then
1865 Left_Len := String_Length (Strval (Left_Str));
1867 -- If the left operand is the empty string, and the right operand
1868 -- is a string literal (the case of "" & "..."), the result is the
1869 -- value of the right operand. This optimization is important when
1870 -- Is_Folded_In_Parser, to avoid copying an enormous right
1873 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
1874 Folded_Val := Strval (Right_Str);
1876 Start_String (Strval (Left_Str));
1881 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
1885 -- Now append the characters of the right operand, unless we
1886 -- optimized the "" & "..." case above.
1888 if Nkind (Right_Str) = N_String_Literal then
1889 if Left_Len /= 0 then
1890 Store_String_Chars (Strval (Right_Str));
1891 Folded_Val := End_String;
1894 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
1895 Folded_Val := End_String;
1898 Set_Is_Static_Expression (N, Stat);
1900 -- If left operand is the empty string, the result is the
1901 -- right operand, including its bounds if anomalous.
1904 and then Is_Array_Type (Etype (Right))
1905 and then Etype (Right) /= Any_String
1907 Set_Etype (N, Etype (Right));
1910 Fold_Str (N, Folded_Val, Static => Stat);
1912 end Eval_Concatenation;
1914 ----------------------
1915 -- Eval_Entity_Name --
1916 ----------------------
1918 -- This procedure is used for identifiers and expanded names other than
1919 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1920 -- static if they denote a static constant (RM 4.9(6)) or if the name
1921 -- denotes an enumeration literal (RM 4.9(22)).
1923 procedure Eval_Entity_Name (N : Node_Id) is
1924 Def_Id : constant Entity_Id := Entity (N);
1928 -- Enumeration literals are always considered to be constants
1929 -- and cannot raise constraint error (RM 4.9(22)).
1931 if Ekind (Def_Id) = E_Enumeration_Literal then
1932 Set_Is_Static_Expression (N);
1935 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1936 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1937 -- it does not violate 10.2.1(8) here, since this is not a variable.
1939 elsif Ekind (Def_Id) = E_Constant then
1941 -- Deferred constants must always be treated as nonstatic outside the
1942 -- scope of their full view.
1944 if Present (Full_View (Def_Id))
1945 and then not In_Open_Scopes (Scope (Def_Id))
1949 Val := Constant_Value (Def_Id);
1952 if Present (Val) then
1953 Set_Is_Static_Expression
1954 (N, Is_Static_Expression (Val)
1955 and then Is_Static_Subtype (Etype (Def_Id)));
1956 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1958 if not Is_Static_Expression (N)
1959 and then not Is_Generic_Type (Etype (N))
1961 Validate_Static_Object_Name (N);
1964 -- Mark constant condition in SCOs
1967 and then Comes_From_Source (N)
1968 and then Is_Boolean_Type (Etype (Def_Id))
1969 and then Compile_Time_Known_Value (N)
1971 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
1978 -- Fall through if the name is not static
1980 Validate_Static_Object_Name (N);
1981 end Eval_Entity_Name;
1983 ------------------------
1984 -- Eval_If_Expression --
1985 ------------------------
1987 -- We can fold to a static expression if the condition and both dependent
1988 -- expressions are static. Otherwise, the only required processing is to do
1989 -- the check for non-static context for the then and else expressions.
1991 procedure Eval_If_Expression (N : Node_Id) is
1992 Condition : constant Node_Id := First (Expressions (N));
1993 Then_Expr : constant Node_Id := Next (Condition);
1994 Else_Expr : constant Node_Id := Next (Then_Expr);
1996 Non_Result : Node_Id;
1998 Rstat : constant Boolean :=
1999 Is_Static_Expression (Condition)
2001 Is_Static_Expression (Then_Expr)
2003 Is_Static_Expression (Else_Expr);
2006 -- If any operand is Any_Type, just propagate to result and do not try
2007 -- to fold, this prevents cascaded errors.
2009 if Etype (Condition) = Any_Type or else
2010 Etype (Then_Expr) = Any_Type or else
2011 Etype (Else_Expr) = Any_Type
2013 Set_Etype (N, Any_Type);
2014 Set_Is_Static_Expression (N, False);
2017 -- Static case where we can fold. Note that we don't try to fold cases
2018 -- where the condition is known at compile time, but the result is
2019 -- non-static. This avoids possible cases of infinite recursion where
2020 -- the expander puts in a redundant test and we remove it. Instead we
2021 -- deal with these cases in the expander.
2025 -- Select result operand
2027 if Is_True (Expr_Value (Condition)) then
2028 Result := Then_Expr;
2029 Non_Result := Else_Expr;
2031 Result := Else_Expr;
2032 Non_Result := Then_Expr;
2035 -- Note that it does not matter if the non-result operand raises a
2036 -- Constraint_Error, but if the result raises constraint error then
2037 -- we replace the node with a raise constraint error. This will
2038 -- properly propagate Raises_Constraint_Error since this flag is
2041 if Raises_Constraint_Error (Result) then
2042 Rewrite_In_Raise_CE (N, Result);
2043 Check_Non_Static_Context (Non_Result);
2045 -- Otherwise the result operand replaces the original node
2048 Rewrite (N, Relocate_Node (Result));
2051 -- Case of condition not known at compile time
2054 Check_Non_Static_Context (Condition);
2055 Check_Non_Static_Context (Then_Expr);
2056 Check_Non_Static_Context (Else_Expr);
2059 Set_Is_Static_Expression (N, Rstat);
2060 end Eval_If_Expression;
2062 ----------------------------
2063 -- Eval_Indexed_Component --
2064 ----------------------------
2066 -- Indexed components are never static, so we need to perform the check
2067 -- for non-static context on the index values. Then, we check if the
2068 -- value can be obtained at compile time, even though it is non-static.
2070 procedure Eval_Indexed_Component (N : Node_Id) is
2074 -- Check for non-static context on index values
2076 Expr := First (Expressions (N));
2077 while Present (Expr) loop
2078 Check_Non_Static_Context (Expr);
2082 -- If the indexed component appears in an object renaming declaration
2083 -- then we do not want to try to evaluate it, since in this case we
2084 -- need the identity of the array element.
2086 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2089 -- Similarly if the indexed component appears as the prefix of an
2090 -- attribute we don't want to evaluate it, because at least for
2091 -- some cases of attributes we need the identify (e.g. Access, Size)
2093 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2097 -- Note: there are other cases, such as the left side of an assignment,
2098 -- or an OUT parameter for a call, where the replacement results in the
2099 -- illegal use of a constant, But these cases are illegal in the first
2100 -- place, so the replacement, though silly, is harmless.
2102 -- Now see if this is a constant array reference
2104 if List_Length (Expressions (N)) = 1
2105 and then Is_Entity_Name (Prefix (N))
2106 and then Ekind (Entity (Prefix (N))) = E_Constant
2107 and then Present (Constant_Value (Entity (Prefix (N))))
2110 Loc : constant Source_Ptr := Sloc (N);
2111 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2112 Sub : constant Node_Id := First (Expressions (N));
2118 -- Linear one's origin subscript value for array reference
2121 -- Lower bound of the first array index
2124 -- Value from constant array
2127 Atyp := Etype (Arr);
2129 if Is_Access_Type (Atyp) then
2130 Atyp := Designated_Type (Atyp);
2133 -- If we have an array type (we should have but perhaps there are
2134 -- error cases where this is not the case), then see if we can do
2135 -- a constant evaluation of the array reference.
2137 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2138 if Ekind (Atyp) = E_String_Literal_Subtype then
2139 Lbd := String_Literal_Low_Bound (Atyp);
2141 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2144 if Compile_Time_Known_Value (Sub)
2145 and then Nkind (Arr) = N_Aggregate
2146 and then Compile_Time_Known_Value (Lbd)
2147 and then Is_Discrete_Type (Component_Type (Atyp))
2149 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2151 if List_Length (Expressions (Arr)) >= Lin then
2152 Elm := Pick (Expressions (Arr), Lin);
2154 -- If the resulting expression is compile time known,
2155 -- then we can rewrite the indexed component with this
2156 -- value, being sure to mark the result as non-static.
2157 -- We also reset the Sloc, in case this generates an
2158 -- error later on (e.g. 136'Access).
2160 if Compile_Time_Known_Value (Elm) then
2161 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2162 Set_Is_Static_Expression (N, False);
2167 -- We can also constant-fold if the prefix is a string literal.
2168 -- This will be useful in an instantiation or an inlining.
2170 elsif Compile_Time_Known_Value (Sub)
2171 and then Nkind (Arr) = N_String_Literal
2172 and then Compile_Time_Known_Value (Lbd)
2173 and then Expr_Value (Lbd) = 1
2174 and then Expr_Value (Sub) <=
2175 String_Literal_Length (Etype (Arr))
2178 C : constant Char_Code :=
2179 Get_String_Char (Strval (Arr),
2180 UI_To_Int (Expr_Value (Sub)));
2182 Set_Character_Literal_Name (C);
2185 Make_Character_Literal (Loc,
2187 Char_Literal_Value => UI_From_CC (C));
2188 Set_Etype (Elm, Component_Type (Atyp));
2189 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2190 Set_Is_Static_Expression (N, False);
2196 end Eval_Indexed_Component;
2198 --------------------------
2199 -- Eval_Integer_Literal --
2200 --------------------------
2202 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2203 -- as static by the analyzer. The reason we did it that early is to allow
2204 -- the possibility of turning off the Is_Static_Expression flag after
2205 -- analysis, but before resolution, when integer literals are generated in
2206 -- the expander that do not correspond to static expressions.
2208 procedure Eval_Integer_Literal (N : Node_Id) is
2209 T : constant Entity_Id := Etype (N);
2211 function In_Any_Integer_Context return Boolean;
2212 -- If the literal is resolved with a specific type in a context where
2213 -- the expected type is Any_Integer, there are no range checks on the
2214 -- literal. By the time the literal is evaluated, it carries the type
2215 -- imposed by the enclosing expression, and we must recover the context
2216 -- to determine that Any_Integer is meant.
2218 ----------------------------
2219 -- In_Any_Integer_Context --
2220 ----------------------------
2222 function In_Any_Integer_Context return Boolean is
2223 Par : constant Node_Id := Parent (N);
2224 K : constant Node_Kind := Nkind (Par);
2227 -- Any_Integer also appears in digits specifications for real types,
2228 -- but those have bounds smaller that those of any integer base type,
2229 -- so we can safely ignore these cases.
2231 return Nkind_In (K, N_Number_Declaration,
2232 N_Attribute_Reference,
2233 N_Attribute_Definition_Clause,
2234 N_Modular_Type_Definition,
2235 N_Signed_Integer_Type_Definition);
2236 end In_Any_Integer_Context;
2238 -- Start of processing for Eval_Integer_Literal
2242 -- If the literal appears in a non-expression context, then it is
2243 -- certainly appearing in a non-static context, so check it. This is
2244 -- actually a redundant check, since Check_Non_Static_Context would
2245 -- check it, but it seems worth while avoiding the call.
2247 if Nkind (Parent (N)) not in N_Subexpr
2248 and then not In_Any_Integer_Context
2250 Check_Non_Static_Context (N);
2253 -- Modular integer literals must be in their base range
2255 if Is_Modular_Integer_Type (T)
2256 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2260 end Eval_Integer_Literal;
2262 ---------------------
2263 -- Eval_Logical_Op --
2264 ---------------------
2266 -- Logical operations are static functions, so the result is potentially
2267 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2269 procedure Eval_Logical_Op (N : Node_Id) is
2270 Left : constant Node_Id := Left_Opnd (N);
2271 Right : constant Node_Id := Right_Opnd (N);
2276 -- If not foldable we are done
2278 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2284 -- Compile time evaluation of logical operation
2287 Left_Int : constant Uint := Expr_Value (Left);
2288 Right_Int : constant Uint := Expr_Value (Right);
2291 -- VMS includes bitwise operations on signed types
2293 if Is_Modular_Integer_Type (Etype (N))
2294 or else Is_VMS_Operator (Entity (N))
2297 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2298 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2301 To_Bits (Left_Int, Left_Bits);
2302 To_Bits (Right_Int, Right_Bits);
2304 -- Note: should really be able to use array ops instead of
2305 -- these loops, but they weren't working at the time ???
2307 if Nkind (N) = N_Op_And then
2308 for J in Left_Bits'Range loop
2309 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2312 elsif Nkind (N) = N_Op_Or then
2313 for J in Left_Bits'Range loop
2314 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2318 pragma Assert (Nkind (N) = N_Op_Xor);
2320 for J in Left_Bits'Range loop
2321 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2325 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2329 pragma Assert (Is_Boolean_Type (Etype (N)));
2331 if Nkind (N) = N_Op_And then
2333 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2335 elsif Nkind (N) = N_Op_Or then
2337 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2340 pragma Assert (Nkind (N) = N_Op_Xor);
2342 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2346 end Eval_Logical_Op;
2348 ------------------------
2349 -- Eval_Membership_Op --
2350 ------------------------
2352 -- A membership test is potentially static if the expression is static, and
2353 -- the range is a potentially static range, or is a subtype mark denoting a
2354 -- static subtype (RM 4.9(12)).
2356 procedure Eval_Membership_Op (N : Node_Id) is
2357 Left : constant Node_Id := Left_Opnd (N);
2358 Right : constant Node_Id := Right_Opnd (N);
2367 -- Ignore if error in either operand, except to make sure that Any_Type
2368 -- is properly propagated to avoid junk cascaded errors.
2370 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2371 Set_Etype (N, Any_Type);
2375 -- Ignore if types involved have predicates
2377 if Present (Predicate_Function (Etype (Left)))
2379 Present (Predicate_Function (Etype (Right)))
2384 -- Case of right operand is a subtype name
2386 if Is_Entity_Name (Right) then
2387 Def_Id := Entity (Right);
2389 if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
2390 and then Is_OK_Static_Subtype (Def_Id)
2392 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2394 if not Fold or else not Stat then
2398 Check_Non_Static_Context (Left);
2402 -- For string membership tests we will check the length further on
2404 if not Is_String_Type (Def_Id) then
2405 Lo := Type_Low_Bound (Def_Id);
2406 Hi := Type_High_Bound (Def_Id);
2412 -- Case of right operand is a range
2415 if Is_Static_Range (Right) then
2416 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2418 if not Fold or else not Stat then
2421 -- If one bound of range raises CE, then don't try to fold
2423 elsif not Is_OK_Static_Range (Right) then
2424 Check_Non_Static_Context (Left);
2429 Check_Non_Static_Context (Left);
2433 -- Here we know range is an OK static range
2435 Lo := Low_Bound (Right);
2436 Hi := High_Bound (Right);
2439 -- For strings we check that the length of the string expression is
2440 -- compatible with the string subtype if the subtype is constrained,
2441 -- or if unconstrained then the test is always true.
2443 if Is_String_Type (Etype (Right)) then
2444 if not Is_Constrained (Etype (Right)) then
2449 Typlen : constant Uint := String_Type_Len (Etype (Right));
2450 Strlen : constant Uint :=
2452 (String_Length (Strval (Get_String_Val (Left))));
2454 Result := (Typlen = Strlen);
2458 -- Fold the membership test. We know we have a static range and Lo and
2459 -- Hi are set to the expressions for the end points of this range.
2461 elsif Is_Real_Type (Etype (Right)) then
2463 Leftval : constant Ureal := Expr_Value_R (Left);
2465 Result := Expr_Value_R (Lo) <= Leftval
2466 and then Leftval <= Expr_Value_R (Hi);
2471 Leftval : constant Uint := Expr_Value (Left);
2473 Result := Expr_Value (Lo) <= Leftval
2474 and then Leftval <= Expr_Value (Hi);
2478 if Nkind (N) = N_Not_In then
2479 Result := not Result;
2482 Fold_Uint (N, Test (Result), True);
2484 Warn_On_Known_Condition (N);
2485 end Eval_Membership_Op;
2487 ------------------------
2488 -- Eval_Named_Integer --
2489 ------------------------
2491 procedure Eval_Named_Integer (N : Node_Id) is
2494 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2495 end Eval_Named_Integer;
2497 ---------------------
2498 -- Eval_Named_Real --
2499 ---------------------
2501 procedure Eval_Named_Real (N : Node_Id) is
2504 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2505 end Eval_Named_Real;
2511 -- Exponentiation is a static functions, so the result is potentially
2512 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2514 procedure Eval_Op_Expon (N : Node_Id) is
2515 Left : constant Node_Id := Left_Opnd (N);
2516 Right : constant Node_Id := Right_Opnd (N);
2521 -- If not foldable we are done
2523 Test_Expression_Is_Foldable
2524 (N, Left, Right, Stat, Fold, CRT_Safe => True);
2526 -- Return if not foldable
2532 if Configurable_Run_Time_Mode and not Stat then
2536 -- Fold exponentiation operation
2539 Right_Int : constant Uint := Expr_Value (Right);
2544 if Is_Integer_Type (Etype (Left)) then
2546 Left_Int : constant Uint := Expr_Value (Left);
2550 -- Exponentiation of an integer raises Constraint_Error for a
2551 -- negative exponent (RM 4.5.6).
2553 if Right_Int < 0 then
2554 Apply_Compile_Time_Constraint_Error
2555 (N, "integer exponent negative", CE_Range_Check_Failed,
2560 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2561 Result := Left_Int ** Right_Int;
2566 if Is_Modular_Integer_Type (Etype (N)) then
2567 Result := Result mod Modulus (Etype (N));
2570 Fold_Uint (N, Result, Stat);
2578 Left_Real : constant Ureal := Expr_Value_R (Left);
2581 -- Cannot have a zero base with a negative exponent
2583 if UR_Is_Zero (Left_Real) then
2585 if Right_Int < 0 then
2586 Apply_Compile_Time_Constraint_Error
2587 (N, "zero ** negative integer", CE_Range_Check_Failed,
2591 Fold_Ureal (N, Ureal_0, Stat);
2595 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2606 -- The not operation is a static functions, so the result is potentially
2607 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2609 procedure Eval_Op_Not (N : Node_Id) is
2610 Right : constant Node_Id := Right_Opnd (N);
2615 -- If not foldable we are done
2617 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2623 -- Fold not operation
2626 Rint : constant Uint := Expr_Value (Right);
2627 Typ : constant Entity_Id := Etype (N);
2630 -- Negation is equivalent to subtracting from the modulus minus one.
2631 -- For a binary modulus this is equivalent to the ones-complement of
2632 -- the original value. For non-binary modulus this is an arbitrary
2633 -- but consistent definition.
2635 if Is_Modular_Integer_Type (Typ) then
2636 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2637 else pragma Assert (Is_Boolean_Type (Typ));
2638 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2641 Set_Is_Static_Expression (N, Stat);
2645 -------------------------------
2646 -- Eval_Qualified_Expression --
2647 -------------------------------
2649 -- A qualified expression is potentially static if its subtype mark denotes
2650 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2652 procedure Eval_Qualified_Expression (N : Node_Id) is
2653 Operand : constant Node_Id := Expression (N);
2654 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2661 -- Can only fold if target is string or scalar and subtype is static.
2662 -- Also, do not fold if our parent is an allocator (this is because the
2663 -- qualified expression is really part of the syntactic structure of an
2664 -- allocator, and we do not want to end up with something that
2665 -- corresponds to "new 1" where the 1 is the result of folding a
2666 -- qualified expression).
2668 if not Is_Static_Subtype (Target_Type)
2669 or else Nkind (Parent (N)) = N_Allocator
2671 Check_Non_Static_Context (Operand);
2673 -- If operand is known to raise constraint_error, set the flag on the
2674 -- expression so it does not get optimized away.
2676 if Nkind (Operand) = N_Raise_Constraint_Error then
2677 Set_Raises_Constraint_Error (N);
2683 -- If not foldable we are done
2685 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2690 -- Don't try fold if target type has constraint error bounds
2692 elsif not Is_OK_Static_Subtype (Target_Type) then
2693 Set_Raises_Constraint_Error (N);
2697 -- Here we will fold, save Print_In_Hex indication
2699 Hex := Nkind (Operand) = N_Integer_Literal
2700 and then Print_In_Hex (Operand);
2702 -- Fold the result of qualification
2704 if Is_Discrete_Type (Target_Type) then
2705 Fold_Uint (N, Expr_Value (Operand), Stat);
2707 -- Preserve Print_In_Hex indication
2709 if Hex and then Nkind (N) = N_Integer_Literal then
2710 Set_Print_In_Hex (N);
2713 elsif Is_Real_Type (Target_Type) then
2714 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
2717 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
2720 Set_Is_Static_Expression (N, False);
2722 Check_String_Literal_Length (N, Target_Type);
2728 -- The expression may be foldable but not static
2730 Set_Is_Static_Expression (N, Stat);
2732 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
2735 end Eval_Qualified_Expression;
2737 -----------------------
2738 -- Eval_Real_Literal --
2739 -----------------------
2741 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2742 -- as static by the analyzer. The reason we did it that early is to allow
2743 -- the possibility of turning off the Is_Static_Expression flag after
2744 -- analysis, but before resolution, when integer literals are generated
2745 -- in the expander that do not correspond to static expressions.
2747 procedure Eval_Real_Literal (N : Node_Id) is
2748 PK : constant Node_Kind := Nkind (Parent (N));
2751 -- If the literal appears in a non-expression context and not as part of
2752 -- a number declaration, then it is appearing in a non-static context,
2755 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
2756 Check_Non_Static_Context (N);
2758 end Eval_Real_Literal;
2760 ------------------------
2761 -- Eval_Relational_Op --
2762 ------------------------
2764 -- Relational operations are static functions, so the result is static if
2765 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
2766 -- the result is never static, even if the operands are.
2768 procedure Eval_Relational_Op (N : Node_Id) is
2769 Left : constant Node_Id := Left_Opnd (N);
2770 Right : constant Node_Id := Right_Opnd (N);
2771 Typ : constant Entity_Id := Etype (Left);
2772 Otype : Entity_Id := Empty;
2776 -- One special case to deal with first. If we can tell that the result
2777 -- will be false because the lengths of one or more index subtypes are
2778 -- compile time known and different, then we can replace the entire
2779 -- result by False. We only do this for one dimensional arrays, because
2780 -- the case of multi-dimensional arrays is rare and too much trouble. If
2781 -- one of the operands is an illegal aggregate, its type might still be
2782 -- an arbitrary composite type, so nothing to do.
2784 if Is_Array_Type (Typ)
2785 and then Typ /= Any_Composite
2786 and then Number_Dimensions (Typ) = 1
2787 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
2789 if Raises_Constraint_Error (Left)
2791 Raises_Constraint_Error (Right)
2796 -- OK, we have the case where we may be able to do this fold
2798 Length_Mismatch : declare
2799 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
2800 -- If Op is an expression for a constrained array with a known at
2801 -- compile time length, then Len is set to this (non-negative
2802 -- length). Otherwise Len is set to minus 1.
2804 -----------------------
2805 -- Get_Static_Length --
2806 -----------------------
2808 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2812 -- First easy case string literal
2814 if Nkind (Op) = N_String_Literal then
2815 Len := UI_From_Int (String_Length (Strval (Op)));
2819 -- Second easy case, not constrained subtype, so no length
2821 if not Is_Constrained (Etype (Op)) then
2822 Len := Uint_Minus_1;
2828 T := Etype (First_Index (Etype (Op)));
2830 -- The simple case, both bounds are known at compile time
2832 if Is_Discrete_Type (T)
2833 and then Compile_Time_Known_Value (Type_Low_Bound (T))
2834 and then Compile_Time_Known_Value (Type_High_Bound (T))
2836 Len := UI_Max (Uint_0,
2837 Expr_Value (Type_High_Bound (T)) -
2838 Expr_Value (Type_Low_Bound (T)) + 1);
2842 -- A more complex case, where the bounds are of the form
2843 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2844 -- either A'First or A'Last (with A an entity name), or X is an
2845 -- entity name, and the two X's are the same and K1 and K2 are
2846 -- known at compile time, in this case, the length can also be
2847 -- computed at compile time, even though the bounds are not
2848 -- known. A common case of this is e.g. (X'First .. X'First+5).
2850 Extract_Length : declare
2851 procedure Decompose_Expr
2853 Ent : out Entity_Id;
2854 Kind : out Character;
2856 -- Given an expression see if it is of the form given above,
2857 -- X [+/- K]. If so Ent is set to the entity in X, Kind is
2858 -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
2859 -- the value of K. If the expression is not of the required
2860 -- form, Ent is set to Empty.
2862 --------------------
2863 -- Decompose_Expr --
2864 --------------------
2866 procedure Decompose_Expr
2868 Ent : out Entity_Id;
2869 Kind : out Character;
2875 if Nkind (Expr) = N_Op_Add
2876 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2878 Exp := Left_Opnd (Expr);
2879 Cons := Expr_Value (Right_Opnd (Expr));
2881 elsif Nkind (Expr) = N_Op_Subtract
2882 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2884 Exp := Left_Opnd (Expr);
2885 Cons := -Expr_Value (Right_Opnd (Expr));
2887 -- If the bound is a constant created to remove side
2888 -- effects, recover original expression to see if it has
2889 -- one of the recognizable forms.
2891 elsif Nkind (Expr) = N_Identifier
2892 and then not Comes_From_Source (Entity (Expr))
2893 and then Ekind (Entity (Expr)) = E_Constant
2895 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
2897 Exp := Expression (Parent (Entity (Expr)));
2898 Decompose_Expr (Exp, Ent, Kind, Cons);
2900 -- If original expression includes an entity, create a
2901 -- reference to it for use below.
2903 if Present (Ent) then
2904 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
2912 -- At this stage Exp is set to the potential X
2914 if Nkind (Exp) = N_Attribute_Reference then
2915 if Attribute_Name (Exp) = Name_First then
2917 elsif Attribute_Name (Exp) = Name_Last then
2924 Exp := Prefix (Exp);
2930 if Is_Entity_Name (Exp) and then Present (Entity (Exp))
2932 Ent := Entity (Exp);
2940 Ent1, Ent2 : Entity_Id;
2941 Kind1, Kind2 : Character;
2942 Cons1, Cons2 : Uint;
2944 -- Start of processing for Extract_Length
2948 (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
2950 (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
2953 and then Kind1 = Kind2
2954 and then Ent1 = Ent2
2956 Len := Cons2 - Cons1 + 1;
2958 Len := Uint_Minus_1;
2961 end Get_Static_Length;
2968 -- Start of processing for Length_Mismatch
2971 Get_Static_Length (Left, Len_L);
2972 Get_Static_Length (Right, Len_R);
2974 if Len_L /= Uint_Minus_1
2975 and then Len_R /= Uint_Minus_1
2976 and then Len_L /= Len_R
2978 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2979 Warn_On_Known_Condition (N);
2982 end Length_Mismatch;
2986 Is_Static_Expression : Boolean;
2988 Is_Foldable : Boolean;
2989 pragma Unreferenced (Is_Foldable);
2992 -- Initialize the value of Is_Static_Expression. The value of
2993 -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
2994 -- since, even when some operand is a variable, we can still perform
2995 -- the static evaluation of the expression in some cases (for
2996 -- example, for a variable of a subtype of Integer we statically
2997 -- know that any value stored in such variable is smaller than
3000 Test_Expression_Is_Foldable
3001 (N, Left, Right, Is_Static_Expression, Is_Foldable);
3003 -- Only comparisons of scalars can give static results. In
3004 -- particular, comparisons of strings never yield a static
3005 -- result, even if both operands are static strings.
3007 if not Is_Scalar_Type (Typ) then
3008 Is_Static_Expression := False;
3009 Set_Is_Static_Expression (N, False);
3012 -- For operators on universal numeric types called as functions with
3013 -- an explicit scope, determine appropriate specific numeric type,
3014 -- and diagnose possible ambiguity.
3016 if Is_Universal_Numeric_Type (Etype (Left))
3018 Is_Universal_Numeric_Type (Etype (Right))
3020 Otype := Find_Universal_Operator_Type (N);
3023 -- For static real type expressions, we cannot use
3024 -- Compile_Time_Compare since it worries about run-time
3025 -- results which are not exact.
3027 if Is_Static_Expression and then Is_Real_Type (Typ) then
3029 Left_Real : constant Ureal := Expr_Value_R (Left);
3030 Right_Real : constant Ureal := Expr_Value_R (Right);
3034 when N_Op_Eq => Result := (Left_Real = Right_Real);
3035 when N_Op_Ne => Result := (Left_Real /= Right_Real);
3036 when N_Op_Lt => Result := (Left_Real < Right_Real);
3037 when N_Op_Le => Result := (Left_Real <= Right_Real);
3038 when N_Op_Gt => Result := (Left_Real > Right_Real);
3039 when N_Op_Ge => Result := (Left_Real >= Right_Real);
3042 raise Program_Error;
3045 Fold_Uint (N, Test (Result), True);
3048 -- For all other cases, we use Compile_Time_Compare to do the compare
3052 CR : constant Compare_Result :=
3053 Compile_Time_Compare
3054 (Left, Right, Assume_Valid => False);
3057 if CR = Unknown then
3065 elsif CR = NE or else CR = GT or else CR = LT then
3072 if CR = NE or else CR = GT or else CR = LT then
3083 elsif CR = EQ or else CR = GT or else CR = GE then
3090 if CR = LT or else CR = EQ or else CR = LE then
3101 elsif CR = EQ or else CR = LT or else CR = LE then
3108 if CR = GT or else CR = EQ or else CR = GE then
3117 raise Program_Error;
3121 Fold_Uint (N, Test (Result), Is_Static_Expression);
3125 -- For the case of a folded relational operator on a specific numeric
3126 -- type, freeze operand type now.
3128 if Present (Otype) then
3129 Freeze_Before (N, Otype);
3132 Warn_On_Known_Condition (N);
3133 end Eval_Relational_Op;
3139 -- Shift operations are intrinsic operations that can never be static, so
3140 -- the only processing required is to perform the required check for a non
3141 -- static context for the two operands.
3143 -- Actually we could do some compile time evaluation here some time ???
3145 procedure Eval_Shift (N : Node_Id) is
3147 Check_Non_Static_Context (Left_Opnd (N));
3148 Check_Non_Static_Context (Right_Opnd (N));
3151 ------------------------
3152 -- Eval_Short_Circuit --
3153 ------------------------
3155 -- A short circuit operation is potentially static if both operands are
3156 -- potentially static (RM 4.9 (13)).
3158 procedure Eval_Short_Circuit (N : Node_Id) is
3159 Kind : constant Node_Kind := Nkind (N);
3160 Left : constant Node_Id := Left_Opnd (N);
3161 Right : constant Node_Id := Right_Opnd (N);
3164 Rstat : constant Boolean :=
3165 Is_Static_Expression (Left)
3167 Is_Static_Expression (Right);
3170 -- Short circuit operations are never static in Ada 83
3172 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3173 Check_Non_Static_Context (Left);
3174 Check_Non_Static_Context (Right);
3178 -- Now look at the operands, we can't quite use the normal call to
3179 -- Test_Expression_Is_Foldable here because short circuit operations
3180 -- are a special case, they can still be foldable, even if the right
3181 -- operand raises constraint error.
3183 -- If either operand is Any_Type, just propagate to result and do not
3184 -- try to fold, this prevents cascaded errors.
3186 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3187 Set_Etype (N, Any_Type);
3190 -- If left operand raises constraint error, then replace node N with
3191 -- the raise constraint error node, and we are obviously not foldable.
3192 -- Is_Static_Expression is set from the two operands in the normal way,
3193 -- and we check the right operand if it is in a non-static context.
3195 elsif Raises_Constraint_Error (Left) then
3197 Check_Non_Static_Context (Right);
3200 Rewrite_In_Raise_CE (N, Left);
3201 Set_Is_Static_Expression (N, Rstat);
3204 -- If the result is not static, then we won't in any case fold
3206 elsif not Rstat then
3207 Check_Non_Static_Context (Left);
3208 Check_Non_Static_Context (Right);
3212 -- Here the result is static, note that, unlike the normal processing
3213 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3214 -- the right operand raises constraint error, that's because it is not
3215 -- significant if the left operand is decisive.
3217 Set_Is_Static_Expression (N);
3219 -- It does not matter if the right operand raises constraint error if
3220 -- it will not be evaluated. So deal specially with the cases where
3221 -- the right operand is not evaluated. Note that we will fold these
3222 -- cases even if the right operand is non-static, which is fine, but
3223 -- of course in these cases the result is not potentially static.
3225 Left_Int := Expr_Value (Left);
3227 if (Kind = N_And_Then and then Is_False (Left_Int))
3229 (Kind = N_Or_Else and then Is_True (Left_Int))
3231 Fold_Uint (N, Left_Int, Rstat);
3235 -- If first operand not decisive, then it does matter if the right
3236 -- operand raises constraint error, since it will be evaluated, so
3237 -- we simply replace the node with the right operand. Note that this
3238 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3239 -- (both are set to True in Right).
3241 if Raises_Constraint_Error (Right) then
3242 Rewrite_In_Raise_CE (N, Right);
3243 Check_Non_Static_Context (Left);
3247 -- Otherwise the result depends on the right operand
3249 Fold_Uint (N, Expr_Value (Right), Rstat);
3251 end Eval_Short_Circuit;
3257 -- Slices can never be static, so the only processing required is to check
3258 -- for non-static context if an explicit range is given.
3260 procedure Eval_Slice (N : Node_Id) is
3261 Drange : constant Node_Id := Discrete_Range (N);
3264 if Nkind (Drange) = N_Range then
3265 Check_Non_Static_Context (Low_Bound (Drange));
3266 Check_Non_Static_Context (High_Bound (Drange));
3269 -- A slice of the form A (subtype), when the subtype is the index of
3270 -- the type of A, is redundant, the slice can be replaced with A, and
3271 -- this is worth a warning.
3273 if Is_Entity_Name (Prefix (N)) then
3275 E : constant Entity_Id := Entity (Prefix (N));
3276 T : constant Entity_Id := Etype (E);
3279 if Ekind (E) = E_Constant
3280 and then Is_Array_Type (T)
3281 and then Is_Entity_Name (Drange)
3283 if Is_Entity_Name (Original_Node (First_Index (T)))
3284 and then Entity (Original_Node (First_Index (T)))
3287 if Warn_On_Redundant_Constructs then
3288 Error_Msg_N ("redundant slice denotes whole array?r?", N);
3291 -- The following might be a useful optimization???
3293 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3300 ---------------------------------
3301 -- Eval_Static_Predicate_Check --
3302 ---------------------------------
3304 function Eval_Static_Predicate_Check
3306 Typ : Entity_Id) return Boolean
3308 Loc : constant Source_Ptr := Sloc (N);
3311 -- Discrete type case
3313 if Is_Discrete_Type (Typ) then
3315 Pred : constant List_Id := Static_Predicate (Typ);
3319 pragma Assert (Present (Pred));
3321 -- The static predicate is a list of alternatives in the proper
3322 -- format for an Ada 2012 membership test. If the argument is a
3323 -- literal, the membership test can be evaluated statically. This
3324 -- is easier than running a full intepretation of the predicate
3325 -- expression, and more efficient in some cases.
3329 Left_Opnd => New_Copy_Tree (N),
3330 Right_Opnd => Empty,
3331 Alternatives => Pred);
3332 Analyze_And_Resolve (Test, Standard_Boolean);
3334 return Nkind (Test) = N_Identifier
3335 and then Entity (Test) = Standard_True;
3341 pragma Assert (Is_Real_Type (Typ));
3342 Error_Msg_N ("??real predicate not applied", N);
3345 end Eval_Static_Predicate_Check;
3347 -------------------------
3348 -- Eval_String_Literal --
3349 -------------------------
3351 procedure Eval_String_Literal (N : Node_Id) is
3352 Typ : constant Entity_Id := Etype (N);
3353 Bas : constant Entity_Id := Base_Type (Typ);
3359 -- Nothing to do if error type (handles cases like default expressions
3360 -- or generics where we have not yet fully resolved the type).
3362 if Bas = Any_Type or else Bas = Any_String then
3366 -- String literals are static if the subtype is static (RM 4.9(2)), so
3367 -- reset the static expression flag (it was set unconditionally in
3368 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3369 -- the subtype is static by looking at the lower bound.
3371 if Ekind (Typ) = E_String_Literal_Subtype then
3372 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3373 Set_Is_Static_Expression (N, False);
3377 -- Here if Etype of string literal is normal Etype (not yet possible,
3378 -- but may be possible in future).
3380 elsif not Is_OK_Static_Expression
3381 (Type_Low_Bound (Etype (First_Index (Typ))))
3383 Set_Is_Static_Expression (N, False);
3387 -- If original node was a type conversion, then result if non-static
3389 if Nkind (Original_Node (N)) = N_Type_Conversion then
3390 Set_Is_Static_Expression (N, False);
3394 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3395 -- if its bounds are outside the index base type and this index type is
3396 -- static. This can happen in only two ways. Either the string literal
3397 -- is too long, or it is null, and the lower bound is type'First. In
3398 -- either case it is the upper bound that is out of range of the index
3400 if Ada_Version >= Ada_95 then
3401 if Root_Type (Bas) = Standard_String
3403 Root_Type (Bas) = Standard_Wide_String
3405 Root_Type (Bas) = Standard_Wide_Wide_String
3407 Xtp := Standard_Positive;
3409 Xtp := Etype (First_Index (Bas));
3412 if Ekind (Typ) = E_String_Literal_Subtype then
3413 Lo := String_Literal_Low_Bound (Typ);
3415 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3418 -- Check for string too long
3420 Len := String_Length (Strval (N));
3422 if UI_From_Int (Len) > String_Type_Len (Bas) then
3424 -- Issue message. Note that this message is a warning if the
3425 -- string literal is not marked as static (happens in some cases
3426 -- of folding strings known at compile time, but not static).
3427 -- Furthermore in such cases, we reword the message, since there
3428 -- is no string literal in the source program.
3430 if Is_Static_Expression (N) then
3431 Apply_Compile_Time_Constraint_Error
3432 (N, "string literal too long for}", CE_Length_Check_Failed,
3434 Typ => First_Subtype (Bas));
3436 Apply_Compile_Time_Constraint_Error
3437 (N, "string value too long for}", CE_Length_Check_Failed,
3439 Typ => First_Subtype (Bas),
3443 -- Test for null string not allowed
3446 and then not Is_Generic_Type (Xtp)
3448 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3450 -- Same specialization of message
3452 if Is_Static_Expression (N) then
3453 Apply_Compile_Time_Constraint_Error
3454 (N, "null string literal not allowed for}",
3455 CE_Length_Check_Failed,
3457 Typ => First_Subtype (Bas));
3459 Apply_Compile_Time_Constraint_Error
3460 (N, "null string value not allowed for}",
3461 CE_Length_Check_Failed,
3463 Typ => First_Subtype (Bas),
3468 end Eval_String_Literal;
3470 --------------------------
3471 -- Eval_Type_Conversion --
3472 --------------------------
3474 -- A type conversion is potentially static if its subtype mark is for a
3475 -- static scalar subtype, and its operand expression is potentially static
3478 procedure Eval_Type_Conversion (N : Node_Id) is
3479 Operand : constant Node_Id := Expression (N);
3480 Source_Type : constant Entity_Id := Etype (Operand);
3481 Target_Type : constant Entity_Id := Etype (N);
3486 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3487 -- Returns true if type T is an integer type, or if it is a fixed-point
3488 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3489 -- on the conversion node).
3491 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3492 -- Returns true if type T is a floating-point type, or if it is a
3493 -- fixed-point type that is not to be treated as an integer (i.e. the
3494 -- flag Conversion_OK is not set on the conversion node).
3496 ------------------------------
3497 -- To_Be_Treated_As_Integer --
3498 ------------------------------
3500 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3504 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3505 end To_Be_Treated_As_Integer;
3507 ---------------------------
3508 -- To_Be_Treated_As_Real --
3509 ---------------------------
3511 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3514 Is_Floating_Point_Type (T)
3515 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3516 end To_Be_Treated_As_Real;
3518 -- Start of processing for Eval_Type_Conversion
3521 -- Cannot fold if target type is non-static or if semantic error
3523 if not Is_Static_Subtype (Target_Type) then
3524 Check_Non_Static_Context (Operand);
3526 elsif Error_Posted (N) then
3530 -- If not foldable we are done
3532 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3537 -- Don't try fold if target type has constraint error bounds
3539 elsif not Is_OK_Static_Subtype (Target_Type) then
3540 Set_Raises_Constraint_Error (N);
3544 -- Remaining processing depends on operand types. Note that in the
3545 -- following type test, fixed-point counts as real unless the flag
3546 -- Conversion_OK is set, in which case it counts as integer.
3548 -- Fold conversion, case of string type. The result is not static
3550 if Is_String_Type (Target_Type) then
3551 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3554 -- Fold conversion, case of integer target type
3556 elsif To_Be_Treated_As_Integer (Target_Type) then
3561 -- Integer to integer conversion
3563 if To_Be_Treated_As_Integer (Source_Type) then
3564 Result := Expr_Value (Operand);
3566 -- Real to integer conversion
3569 Result := UR_To_Uint (Expr_Value_R (Operand));
3572 -- If fixed-point type (Conversion_OK must be set), then the
3573 -- result is logically an integer, but we must replace the
3574 -- conversion with the corresponding real literal, since the
3575 -- type from a semantic point of view is still fixed-point.
3577 if Is_Fixed_Point_Type (Target_Type) then
3579 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3581 -- Otherwise result is integer literal
3584 Fold_Uint (N, Result, Stat);
3588 -- Fold conversion, case of real target type
3590 elsif To_Be_Treated_As_Real (Target_Type) then
3595 if To_Be_Treated_As_Real (Source_Type) then
3596 Result := Expr_Value_R (Operand);
3598 Result := UR_From_Uint (Expr_Value (Operand));
3601 Fold_Ureal (N, Result, Stat);
3604 -- Enumeration types
3607 Fold_Uint (N, Expr_Value (Operand), Stat);
3610 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3614 end Eval_Type_Conversion;
3620 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3621 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3623 procedure Eval_Unary_Op (N : Node_Id) is
3624 Right : constant Node_Id := Right_Opnd (N);
3625 Otype : Entity_Id := Empty;
3630 -- If not foldable we are done
3632 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3638 if Etype (Right) = Universal_Integer
3640 Etype (Right) = Universal_Real
3642 Otype := Find_Universal_Operator_Type (N);
3645 -- Fold for integer case
3647 if Is_Integer_Type (Etype (N)) then
3649 Rint : constant Uint := Expr_Value (Right);
3653 -- In the case of modular unary plus and abs there is no need
3654 -- to adjust the result of the operation since if the original
3655 -- operand was in bounds the result will be in the bounds of the
3656 -- modular type. However, in the case of modular unary minus the
3657 -- result may go out of the bounds of the modular type and needs
3660 if Nkind (N) = N_Op_Plus then
3663 elsif Nkind (N) = N_Op_Minus then
3664 if Is_Modular_Integer_Type (Etype (N)) then
3665 Result := (-Rint) mod Modulus (Etype (N));
3671 pragma Assert (Nkind (N) = N_Op_Abs);
3675 Fold_Uint (N, Result, Stat);
3678 -- Fold for real case
3680 elsif Is_Real_Type (Etype (N)) then
3682 Rreal : constant Ureal := Expr_Value_R (Right);
3686 if Nkind (N) = N_Op_Plus then
3688 elsif Nkind (N) = N_Op_Minus then
3689 Result := UR_Negate (Rreal);
3691 pragma Assert (Nkind (N) = N_Op_Abs);
3692 Result := abs Rreal;
3695 Fold_Ureal (N, Result, Stat);
3699 -- If the operator was resolved to a specific type, make sure that type
3700 -- is frozen even if the expression is folded into a literal (which has
3701 -- a universal type).
3703 if Present (Otype) then
3704 Freeze_Before (N, Otype);
3708 -------------------------------
3709 -- Eval_Unchecked_Conversion --
3710 -------------------------------
3712 -- Unchecked conversions can never be static, so the only required
3713 -- processing is to check for a non-static context for the operand.
3715 procedure Eval_Unchecked_Conversion (N : Node_Id) is
3717 Check_Non_Static_Context (Expression (N));
3718 end Eval_Unchecked_Conversion;
3720 --------------------
3721 -- Expr_Rep_Value --
3722 --------------------
3724 function Expr_Rep_Value (N : Node_Id) return Uint is
3725 Kind : constant Node_Kind := Nkind (N);
3729 if Is_Entity_Name (N) then
3732 -- An enumeration literal that was either in the source or created
3733 -- as a result of static evaluation.
3735 if Ekind (Ent) = E_Enumeration_Literal then
3736 return Enumeration_Rep (Ent);
3738 -- A user defined static constant
3741 pragma Assert (Ekind (Ent) = E_Constant);
3742 return Expr_Rep_Value (Constant_Value (Ent));
3745 -- An integer literal that was either in the source or created as a
3746 -- result of static evaluation.
3748 elsif Kind = N_Integer_Literal then
3751 -- A real literal for a fixed-point type. This must be the fixed-point
3752 -- case, either the literal is of a fixed-point type, or it is a bound
3753 -- of a fixed-point type, with type universal real. In either case we
3754 -- obtain the desired value from Corresponding_Integer_Value.
3756 elsif Kind = N_Real_Literal then
3757 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3758 return Corresponding_Integer_Value (N);
3760 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3762 elsif Kind = N_Attribute_Reference
3763 and then Attribute_Name (N) = Name_Null_Parameter
3767 -- Otherwise must be character literal
3770 pragma Assert (Kind = N_Character_Literal);
3773 -- Since Character literals of type Standard.Character don't have any
3774 -- defining character literals built for them, they do not have their
3775 -- Entity set, so just use their Char code. Otherwise for user-
3776 -- defined character literals use their Pos value as usual which is
3777 -- the same as the Rep value.
3780 return Char_Literal_Value (N);
3782 return Enumeration_Rep (Ent);
3791 function Expr_Value (N : Node_Id) return Uint is
3792 Kind : constant Node_Kind := Nkind (N);
3793 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3798 -- If already in cache, then we know it's compile time known and we can
3799 -- return the value that was previously stored in the cache since
3800 -- compile time known values cannot change.
3802 if CV_Ent.N = N then
3806 -- Otherwise proceed to test value
3808 if Is_Entity_Name (N) then
3811 -- An enumeration literal that was either in the source or created as
3812 -- a result of static evaluation.
3814 if Ekind (Ent) = E_Enumeration_Literal then
3815 Val := Enumeration_Pos (Ent);
3817 -- A user defined static constant
3820 pragma Assert (Ekind (Ent) = E_Constant);
3821 Val := Expr_Value (Constant_Value (Ent));
3824 -- An integer literal that was either in the source or created as a
3825 -- result of static evaluation.
3827 elsif Kind = N_Integer_Literal then
3830 -- A real literal for a fixed-point type. This must be the fixed-point
3831 -- case, either the literal is of a fixed-point type, or it is a bound
3832 -- of a fixed-point type, with type universal real. In either case we
3833 -- obtain the desired value from Corresponding_Integer_Value.
3835 elsif Kind = N_Real_Literal then
3836 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3837 Val := Corresponding_Integer_Value (N);
3839 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3841 elsif Kind = N_Attribute_Reference
3842 and then Attribute_Name (N) = Name_Null_Parameter
3846 -- Otherwise must be character literal
3849 pragma Assert (Kind = N_Character_Literal);
3852 -- Since Character literals of type Standard.Character don't
3853 -- have any defining character literals built for them, they
3854 -- do not have their Entity set, so just use their Char
3855 -- code. Otherwise for user-defined character literals use
3856 -- their Pos value as usual.
3859 Val := Char_Literal_Value (N);
3861 Val := Enumeration_Pos (Ent);
3865 -- Come here with Val set to value to be returned, set cache
3876 function Expr_Value_E (N : Node_Id) return Entity_Id is
3877 Ent : constant Entity_Id := Entity (N);
3879 if Ekind (Ent) = E_Enumeration_Literal then
3882 pragma Assert (Ekind (Ent) = E_Constant);
3883 return Expr_Value_E (Constant_Value (Ent));
3891 function Expr_Value_R (N : Node_Id) return Ureal is
3892 Kind : constant Node_Kind := Nkind (N);
3896 if Kind = N_Real_Literal then
3899 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3901 pragma Assert (Ekind (Ent) = E_Constant);
3902 return Expr_Value_R (Constant_Value (Ent));
3904 elsif Kind = N_Integer_Literal then
3905 return UR_From_Uint (Expr_Value (N));
3907 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3909 elsif Kind = N_Attribute_Reference
3910 and then Attribute_Name (N) = Name_Null_Parameter
3915 -- If we fall through, we have a node that cannot be interpreted as a
3916 -- compile time constant. That is definitely an error.
3918 raise Program_Error;
3925 function Expr_Value_S (N : Node_Id) return Node_Id is
3927 if Nkind (N) = N_String_Literal then
3930 pragma Assert (Ekind (Entity (N)) = E_Constant);
3931 return Expr_Value_S (Constant_Value (Entity (N)));
3935 ----------------------------------
3936 -- Find_Universal_Operator_Type --
3937 ----------------------------------
3939 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
3940 PN : constant Node_Id := Parent (N);
3941 Call : constant Node_Id := Original_Node (N);
3942 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
3944 Is_Fix : constant Boolean :=
3945 Nkind (N) in N_Binary_Op
3946 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
3947 -- A mixed-mode operation in this context indicates the presence of
3948 -- fixed-point type in the designated package.
3950 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
3951 -- Case where N is a relational (or membership) operator (else it is an
3954 In_Membership : constant Boolean :=
3955 Nkind (PN) in N_Membership_Test
3957 Nkind (Right_Opnd (PN)) = N_Range
3959 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
3961 Is_Universal_Numeric_Type
3962 (Etype (Low_Bound (Right_Opnd (PN))))
3964 Is_Universal_Numeric_Type
3965 (Etype (High_Bound (Right_Opnd (PN))));
3966 -- Case where N is part of a membership test with a universal range
3970 Typ1 : Entity_Id := Empty;
3973 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
3974 -- Check whether one operand is a mixed-mode operation that requires the
3975 -- presence of a fixed-point type. Given that all operands are universal
3976 -- and have been constant-folded, retrieve the original function call.
3978 ---------------------------
3979 -- Is_Mixed_Mode_Operand --
3980 ---------------------------
3982 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
3983 Onod : constant Node_Id := Original_Node (Op);
3985 return Nkind (Onod) = N_Function_Call
3986 and then Present (Next_Actual (First_Actual (Onod)))
3987 and then Etype (First_Actual (Onod)) /=
3988 Etype (Next_Actual (First_Actual (Onod)));
3989 end Is_Mixed_Mode_Operand;
3991 -- Start of processing for Find_Universal_Operator_Type
3994 if Nkind (Call) /= N_Function_Call
3995 or else Nkind (Name (Call)) /= N_Expanded_Name
3999 -- There are several cases where the context does not imply the type of
4001 -- - the universal expression appears in a type conversion;
4002 -- - the expression is a relational operator applied to universal
4004 -- - the expression is a membership test with a universal operand
4005 -- and a range with universal bounds.
4007 elsif Nkind (Parent (N)) = N_Type_Conversion
4008 or else Is_Relational
4009 or else In_Membership
4011 Pack := Entity (Prefix (Name (Call)));
4013 -- If the prefix is a package declared elsewhere, iterate over its
4014 -- visible entities, otherwise iterate over all declarations in the
4015 -- designated scope.
4017 if Ekind (Pack) = E_Package
4018 and then not In_Open_Scopes (Pack)
4020 Priv_E := First_Private_Entity (Pack);
4026 E := First_Entity (Pack);
4027 while Present (E) and then E /= Priv_E loop
4028 if Is_Numeric_Type (E)
4029 and then Nkind (Parent (E)) /= N_Subtype_Declaration
4030 and then Comes_From_Source (E)
4031 and then Is_Integer_Type (E) = Is_Int
4032 and then (Nkind (N) in N_Unary_Op
4033 or else Is_Relational
4034 or else Is_Fixed_Point_Type (E) = Is_Fix)
4039 -- Before emitting an error, check for the presence of a
4040 -- mixed-mode operation that specifies a fixed point type.
4044 (Is_Mixed_Mode_Operand (Left_Opnd (N))
4045 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
4046 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
4049 if Is_Fixed_Point_Type (E) then
4054 -- More than one type of the proper class declared in P
4056 Error_Msg_N ("ambiguous operation", N);
4057 Error_Msg_Sloc := Sloc (Typ1);
4058 Error_Msg_N ("\possible interpretation (inherited)#", N);
4059 Error_Msg_Sloc := Sloc (E);
4060 Error_Msg_N ("\possible interpretation (inherited)#", N);
4070 end Find_Universal_Operator_Type;
4072 --------------------------
4073 -- Flag_Non_Static_Expr --
4074 --------------------------
4076 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
4078 if Error_Posted (Expr) and then not All_Errors_Mode then
4081 Error_Msg_F (Msg, Expr);
4082 Why_Not_Static (Expr);
4084 end Flag_Non_Static_Expr;
4090 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
4091 Loc : constant Source_Ptr := Sloc (N);
4092 Typ : constant Entity_Id := Etype (N);
4095 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
4097 -- We now have the literal with the right value, both the actual type
4098 -- and the expected type of this literal are taken from the expression
4099 -- that was evaluated. So now we do the Analyze and Resolve.
4101 -- Note that we have to reset Is_Static_Expression both after the
4102 -- analyze step (because Resolve will evaluate the literal, which
4103 -- will cause semantic errors if it is marked as static), and after
4104 -- the Resolve step (since Resolve in some cases resets this flag).
4107 Set_Is_Static_Expression (N, Static);
4110 Set_Is_Static_Expression (N, Static);
4117 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
4118 Loc : constant Source_Ptr := Sloc (N);
4119 Typ : Entity_Id := Etype (N);
4123 -- If we are folding a named number, retain the entity in the literal,
4126 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
4132 if Is_Private_Type (Typ) then
4133 Typ := Full_View (Typ);
4136 -- For a result of type integer, substitute an N_Integer_Literal node
4137 -- for the result of the compile time evaluation of the expression.
4138 -- For ASIS use, set a link to the original named number when not in
4139 -- a generic context.
4141 if Is_Integer_Type (Typ) then
4142 Rewrite (N, Make_Integer_Literal (Loc, Val));
4143 Set_Original_Entity (N, Ent);
4145 -- Otherwise we have an enumeration type, and we substitute either
4146 -- an N_Identifier or N_Character_Literal to represent the enumeration
4147 -- literal corresponding to the given value, which must always be in
4148 -- range, because appropriate tests have already been made for this.
4150 else pragma Assert (Is_Enumeration_Type (Typ));
4151 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4154 -- We now have the literal with the right value, both the actual type
4155 -- and the expected type of this literal are taken from the expression
4156 -- that was evaluated. So now we do the Analyze and Resolve.
4158 -- Note that we have to reset Is_Static_Expression both after the
4159 -- analyze step (because Resolve will evaluate the literal, which
4160 -- will cause semantic errors if it is marked as static), and after
4161 -- the Resolve step (since Resolve in some cases sets this flag).
4164 Set_Is_Static_Expression (N, Static);
4167 Set_Is_Static_Expression (N, Static);
4174 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4175 Loc : constant Source_Ptr := Sloc (N);
4176 Typ : constant Entity_Id := Etype (N);
4180 -- If we are folding a named number, retain the entity in the literal,
4183 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
4189 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4191 -- Set link to original named number, for ASIS use
4193 Set_Original_Entity (N, Ent);
4195 -- We now have the literal with the right value, both the actual type
4196 -- and the expected type of this literal are taken from the expression
4197 -- that was evaluated. So now we do the Analyze and Resolve.
4199 -- Note that we have to reset Is_Static_Expression both after the
4200 -- analyze step (because Resolve will evaluate the literal, which
4201 -- will cause semantic errors if it is marked as static), and after
4202 -- the Resolve step (since Resolve in some cases sets this flag).
4205 Set_Is_Static_Expression (N, Static);
4208 Set_Is_Static_Expression (N, Static);
4215 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4219 for J in 0 .. B'Last loop
4225 if Non_Binary_Modulus (T) then
4226 V := V mod Modulus (T);
4232 --------------------
4233 -- Get_String_Val --
4234 --------------------
4236 function Get_String_Val (N : Node_Id) return Node_Id is
4238 if Nkind_In (N, N_String_Literal, N_Character_Literal) then
4241 pragma Assert (Is_Entity_Name (N));
4242 return Get_String_Val (Constant_Value (Entity (N)));
4250 procedure Initialize is
4252 CV_Cache := (others => (Node_High_Bound, Uint_0));
4255 --------------------
4256 -- In_Subrange_Of --
4257 --------------------
4259 function In_Subrange_Of
4262 Fixed_Int : Boolean := False) return Boolean
4271 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4274 -- Never in range if both types are not scalar. Don't know if this can
4275 -- actually happen, but just in case.
4277 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then
4280 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4281 -- definitely not compatible with T2.
4283 elsif Is_Floating_Point_Type (T1)
4284 and then Has_Infinities (T1)
4285 and then Is_Floating_Point_Type (T2)
4286 and then not Has_Infinities (T2)
4291 L1 := Type_Low_Bound (T1);
4292 H1 := Type_High_Bound (T1);
4294 L2 := Type_Low_Bound (T2);
4295 H2 := Type_High_Bound (T2);
4297 -- Check bounds to see if comparison possible at compile time
4299 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4301 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4306 -- If bounds not comparable at compile time, then the bounds of T2
4307 -- must be compile time known or we cannot answer the query.
4309 if not Compile_Time_Known_Value (L2)
4310 or else not Compile_Time_Known_Value (H2)
4315 -- If the bounds of T1 are know at compile time then use these
4316 -- ones, otherwise use the bounds of the base type (which are of
4317 -- course always static).
4319 if not Compile_Time_Known_Value (L1) then
4320 L1 := Type_Low_Bound (Base_Type (T1));
4323 if not Compile_Time_Known_Value (H1) then
4324 H1 := Type_High_Bound (Base_Type (T1));
4327 -- Fixed point types should be considered as such only if
4328 -- flag Fixed_Int is set to False.
4330 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4331 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4332 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4335 Expr_Value_R (L2) <= Expr_Value_R (L1)
4337 Expr_Value_R (H2) >= Expr_Value_R (H1);
4341 Expr_Value (L2) <= Expr_Value (L1)
4343 Expr_Value (H2) >= Expr_Value (H1);
4348 -- If any exception occurs, it means that we have some bug in the compiler
4349 -- possibly triggered by a previous error, or by some unforeseen peculiar
4350 -- occurrence. However, this is only an optimization attempt, so there is
4351 -- really no point in crashing the compiler. Instead we just decide, too
4352 -- bad, we can't figure out the answer in this case after all.
4357 -- Debug flag K disables this behavior (useful for debugging)
4359 if Debug_Flag_K then
4370 function Is_In_Range
4373 Assume_Valid : Boolean := False;
4374 Fixed_Int : Boolean := False;
4375 Int_Real : Boolean := False) return Boolean
4379 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
4386 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4387 Typ : constant Entity_Id := Etype (Lo);
4390 if not Compile_Time_Known_Value (Lo)
4391 or else not Compile_Time_Known_Value (Hi)
4396 if Is_Discrete_Type (Typ) then
4397 return Expr_Value (Lo) > Expr_Value (Hi);
4398 else pragma Assert (Is_Real_Type (Typ));
4399 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4403 -----------------------------
4404 -- Is_OK_Static_Expression --
4405 -----------------------------
4407 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4409 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
4410 end Is_OK_Static_Expression;
4412 ------------------------
4413 -- Is_OK_Static_Range --
4414 ------------------------
4416 -- A static range is a range whose bounds are static expressions, or a
4417 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4418 -- We have already converted range attribute references, so we get the
4419 -- "or" part of this rule without needing a special test.
4421 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4423 return Is_OK_Static_Expression (Low_Bound (N))
4424 and then Is_OK_Static_Expression (High_Bound (N));
4425 end Is_OK_Static_Range;
4427 --------------------------
4428 -- Is_OK_Static_Subtype --
4429 --------------------------
4431 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4432 -- neither bound raises constraint error when evaluated.
4434 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4435 Base_T : constant Entity_Id := Base_Type (Typ);
4436 Anc_Subt : Entity_Id;
4439 -- First a quick check on the non static subtype flag. As described
4440 -- in further detail in Einfo, this flag is not decisive in all cases,
4441 -- but if it is set, then the subtype is definitely non-static.
4443 if Is_Non_Static_Subtype (Typ) then
4447 Anc_Subt := Ancestor_Subtype (Typ);
4449 if Anc_Subt = Empty then
4453 if Is_Generic_Type (Root_Type (Base_T))
4454 or else Is_Generic_Actual_Type (Base_T)
4460 elsif Is_String_Type (Typ) then
4462 Ekind (Typ) = E_String_Literal_Subtype
4464 (Is_OK_Static_Subtype (Component_Type (Typ))
4465 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4469 elsif Is_Scalar_Type (Typ) then
4470 if Base_T = Typ then
4474 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4475 -- Get_Type_{Low,High}_Bound.
4477 return Is_OK_Static_Subtype (Anc_Subt)
4478 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4479 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4482 -- Types other than string and scalar types are never static
4487 end Is_OK_Static_Subtype;
4489 ---------------------
4490 -- Is_Out_Of_Range --
4491 ---------------------
4493 function Is_Out_Of_Range
4496 Assume_Valid : Boolean := False;
4497 Fixed_Int : Boolean := False;
4498 Int_Real : Boolean := False) return Boolean
4501 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
4503 end Is_Out_Of_Range;
4505 ---------------------
4506 -- Is_Static_Range --
4507 ---------------------
4509 -- A static range is a range whose bounds are static expressions, or a
4510 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4511 -- We have already converted range attribute references, so we get the
4512 -- "or" part of this rule without needing a special test.
4514 function Is_Static_Range (N : Node_Id) return Boolean is
4516 return Is_Static_Expression (Low_Bound (N))
4518 Is_Static_Expression (High_Bound (N));
4519 end Is_Static_Range;
4521 -----------------------
4522 -- Is_Static_Subtype --
4523 -----------------------
4525 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4527 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4528 Base_T : constant Entity_Id := Base_Type (Typ);
4529 Anc_Subt : Entity_Id;
4532 -- First a quick check on the non static subtype flag. As described
4533 -- in further detail in Einfo, this flag is not decisive in all cases,
4534 -- but if it is set, then the subtype is definitely non-static.
4536 if Is_Non_Static_Subtype (Typ) then
4540 Anc_Subt := Ancestor_Subtype (Typ);
4542 if Anc_Subt = Empty then
4546 if Is_Generic_Type (Root_Type (Base_T))
4547 or else Is_Generic_Actual_Type (Base_T)
4553 elsif Is_String_Type (Typ) then
4555 Ekind (Typ) = E_String_Literal_Subtype
4556 or else (Is_Static_Subtype (Component_Type (Typ))
4557 and then Is_Static_Subtype (Etype (First_Index (Typ))));
4561 elsif Is_Scalar_Type (Typ) then
4562 if Base_T = Typ then
4566 return Is_Static_Subtype (Anc_Subt)
4567 and then Is_Static_Expression (Type_Low_Bound (Typ))
4568 and then Is_Static_Expression (Type_High_Bound (Typ));
4571 -- Types other than string and scalar types are never static
4576 end Is_Static_Subtype;
4578 --------------------
4579 -- Not_Null_Range --
4580 --------------------
4582 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4583 Typ : constant Entity_Id := Etype (Lo);
4586 if not Compile_Time_Known_Value (Lo)
4587 or else not Compile_Time_Known_Value (Hi)
4592 if Is_Discrete_Type (Typ) then
4593 return Expr_Value (Lo) <= Expr_Value (Hi);
4594 else pragma Assert (Is_Real_Type (Typ));
4595 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
4603 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
4605 -- We allow a maximum of 500,000 bits which seems a reasonable limit
4607 if Bits < 500_000 then
4610 -- Error if this maximum is exceeded
4613 Error_Msg_N ("static value too large, capacity exceeded", N);
4622 procedure Out_Of_Range (N : Node_Id) is
4624 -- If we have the static expression case, then this is an illegality
4625 -- in Ada 95 mode, except that in an instance, we never generate an
4626 -- error (if the error is legitimate, it was already diagnosed in the
4627 -- template). The expression to compute the length of a packed array is
4628 -- attached to the array type itself, and deserves a separate message.
4630 if Is_Static_Expression (N)
4631 and then not In_Instance
4632 and then not In_Inlined_Body
4633 and then Ada_Version >= Ada_95
4635 if Nkind (Parent (N)) = N_Defining_Identifier
4636 and then Is_Array_Type (Parent (N))
4637 and then Present (Packed_Array_Impl_Type (Parent (N)))
4638 and then Present (First_Rep_Item (Parent (N)))
4641 ("length of packed array must not exceed Integer''Last",
4642 First_Rep_Item (Parent (N)));
4643 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
4646 Apply_Compile_Time_Constraint_Error
4647 (N, "value not in range of}", CE_Range_Check_Failed);
4650 -- Here we generate a warning for the Ada 83 case, or when we are in an
4651 -- instance, or when we have a non-static expression case.
4654 Apply_Compile_Time_Constraint_Error
4655 (N, "value not in range of}??", CE_Range_Check_Failed);
4659 ----------------------
4660 -- Predicates_Match --
4661 ----------------------
4663 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
4668 if Ada_Version < Ada_2012 then
4671 -- Both types must have predicates or lack them
4673 elsif Has_Predicates (T1) /= Has_Predicates (T2) then
4676 -- Check matching predicates
4681 (T1, Name_Static_Predicate, Check_Parents => False);
4684 (T2, Name_Static_Predicate, Check_Parents => False);
4686 -- Subtypes statically match if the predicate comes from the
4687 -- same declaration, which can only happen if one is a subtype
4688 -- of the other and has no explicit predicate.
4690 -- Suppress warnings on order of actuals, which is otherwise
4691 -- triggered by one of the two calls below.
4693 pragma Warnings (Off);
4694 return Pred1 = Pred2
4695 or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
4696 or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
4697 pragma Warnings (On);
4699 end Predicates_Match;
4701 -------------------------
4702 -- Rewrite_In_Raise_CE --
4703 -------------------------
4705 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
4706 Typ : constant Entity_Id := Etype (N);
4709 -- If we want to raise CE in the condition of a N_Raise_CE node
4710 -- we may as well get rid of the condition.
4712 if Present (Parent (N))
4713 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
4715 Set_Condition (Parent (N), Empty);
4717 -- If the expression raising CE is a N_Raise_CE node, we can use that
4718 -- one. We just preserve the type of the context.
4720 elsif Nkind (Exp) = N_Raise_Constraint_Error then
4724 -- Else build an explcit N_Raise_CE
4728 Make_Raise_Constraint_Error (Sloc (Exp),
4729 Reason => CE_Range_Check_Failed));
4730 Set_Raises_Constraint_Error (N);
4733 end Rewrite_In_Raise_CE;
4735 ---------------------
4736 -- String_Type_Len --
4737 ---------------------
4739 function String_Type_Len (Stype : Entity_Id) return Uint is
4740 NT : constant Entity_Id := Etype (First_Index (Stype));
4744 if Is_OK_Static_Subtype (NT) then
4747 T := Base_Type (NT);
4750 return Expr_Value (Type_High_Bound (T)) -
4751 Expr_Value (Type_Low_Bound (T)) + 1;
4752 end String_Type_Len;
4754 ------------------------------------
4755 -- Subtypes_Statically_Compatible --
4756 ------------------------------------
4758 function Subtypes_Statically_Compatible
4761 Formal_Derived_Matching : Boolean := False) return Boolean
4766 if Is_Scalar_Type (T1) then
4768 -- Definitely compatible if we match
4770 if Subtypes_Statically_Match (T1, T2) then
4773 -- If either subtype is nonstatic then they're not compatible
4775 elsif not Is_Static_Subtype (T1)
4777 not Is_Static_Subtype (T2)
4781 -- If either type has constraint error bounds, then consider that
4782 -- they match to avoid junk cascaded errors here.
4784 elsif not Is_OK_Static_Subtype (T1)
4785 or else not Is_OK_Static_Subtype (T2)
4789 -- Base types must match, but we don't check that (should we???) but
4790 -- we do at least check that both types are real, or both types are
4793 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
4796 -- Here we check the bounds
4800 LB1 : constant Node_Id := Type_Low_Bound (T1);
4801 HB1 : constant Node_Id := Type_High_Bound (T1);
4802 LB2 : constant Node_Id := Type_Low_Bound (T2);
4803 HB2 : constant Node_Id := Type_High_Bound (T2);
4806 if Is_Real_Type (T1) then
4808 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4810 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4812 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4816 (Expr_Value (LB1) > Expr_Value (HB1))
4818 (Expr_Value (LB2) <= Expr_Value (LB1)
4820 Expr_Value (HB1) <= Expr_Value (HB2));
4827 elsif Is_Access_Type (T1) then
4828 return (not Is_Constrained (T2)
4829 or else (Subtypes_Statically_Match
4830 (Designated_Type (T1), Designated_Type (T2))))
4831 and then not (Can_Never_Be_Null (T2)
4832 and then not Can_Never_Be_Null (T1));
4837 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4838 or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching);
4840 end Subtypes_Statically_Compatible;
4842 -------------------------------
4843 -- Subtypes_Statically_Match --
4844 -------------------------------
4846 -- Subtypes statically match if they have statically matching constraints
4847 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4848 -- they are the same identical constraint, or if they are static and the
4849 -- values match (RM 4.9.1(1)).
4851 -- In addition, in GNAT, the object size (Esize) values of the types must
4852 -- match if they are set (unless checking an actual for a formal derived
4853 -- type). The use of 'Object_Size can cause this to be false even if the
4854 -- types would otherwise match in the RM sense.
4856 function Subtypes_Statically_Match
4859 Formal_Derived_Matching : Boolean := False) return Boolean
4862 -- A type always statically matches itself
4867 -- No match if sizes different (from use of 'Object_Size). This test
4868 -- is excluded if Formal_Derived_Matching is True, as the base types
4869 -- can be different in that case and typically have different sizes
4870 -- (and Esizes can be set when Frontend_Layout_On_Target is True).
4872 elsif not Formal_Derived_Matching
4873 and then Known_Static_Esize (T1)
4874 and then Known_Static_Esize (T2)
4875 and then Esize (T1) /= Esize (T2)
4879 -- No match if predicates do not match
4881 elsif not Predicates_Match (T1, T2) then
4886 elsif Is_Scalar_Type (T1) then
4888 -- Base types must be the same
4890 if Base_Type (T1) /= Base_Type (T2) then
4894 -- A constrained numeric subtype never matches an unconstrained
4895 -- subtype, i.e. both types must be constrained or unconstrained.
4897 -- To understand the requirement for this test, see RM 4.9.1(1).
4898 -- As is made clear in RM 3.5.4(11), type Integer, for example is
4899 -- a constrained subtype with constraint bounds matching the bounds
4900 -- of its corresponding unconstrained base type. In this situation,
4901 -- Integer and Integer'Base do not statically match, even though
4902 -- they have the same bounds.
4904 -- We only apply this test to types in Standard and types that appear
4905 -- in user programs. That way, we do not have to be too careful about
4906 -- setting Is_Constrained right for Itypes.
4908 if Is_Numeric_Type (T1)
4909 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4910 and then (Scope (T1) = Standard_Standard
4911 or else Comes_From_Source (T1))
4912 and then (Scope (T2) = Standard_Standard
4913 or else Comes_From_Source (T2))
4917 -- A generic scalar type does not statically match its base type
4918 -- (AI-311). In this case we make sure that the formals, which are
4919 -- first subtypes of their bases, are constrained.
4921 elsif Is_Generic_Type (T1)
4922 and then Is_Generic_Type (T2)
4923 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4928 -- If there was an error in either range, then just assume the types
4929 -- statically match to avoid further junk errors.
4931 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
4932 or else Error_Posted (Scalar_Range (T1))
4933 or else Error_Posted (Scalar_Range (T2))
4938 -- Otherwise both types have bounds that can be compared
4941 LB1 : constant Node_Id := Type_Low_Bound (T1);
4942 HB1 : constant Node_Id := Type_High_Bound (T1);
4943 LB2 : constant Node_Id := Type_Low_Bound (T2);
4944 HB2 : constant Node_Id := Type_High_Bound (T2);
4947 -- If the bounds are the same tree node, then match (common case)
4949 if LB1 = LB2 and then HB1 = HB2 then
4952 -- Otherwise bounds must be static and identical value
4955 if not Is_Static_Subtype (T1)
4956 or else not Is_Static_Subtype (T2)
4960 -- If either type has constraint error bounds, then say that
4961 -- they match to avoid junk cascaded errors here.
4963 elsif not Is_OK_Static_Subtype (T1)
4964 or else not Is_OK_Static_Subtype (T2)
4968 elsif Is_Real_Type (T1) then
4970 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4972 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4976 Expr_Value (LB1) = Expr_Value (LB2)
4978 Expr_Value (HB1) = Expr_Value (HB2);
4983 -- Type with discriminants
4985 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
4987 -- Because of view exchanges in multiple instantiations, conformance
4988 -- checking might try to match a partial view of a type with no
4989 -- discriminants with a full view that has defaulted discriminants.
4990 -- In such a case, use the discriminant constraint of the full view,
4991 -- which must exist because we know that the two subtypes have the
4994 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
4996 if Is_Private_Type (T2)
4997 and then Present (Full_View (T2))
4998 and then Has_Discriminants (Full_View (T2))
5000 return Subtypes_Statically_Match (T1, Full_View (T2));
5002 elsif Is_Private_Type (T1)
5003 and then Present (Full_View (T1))
5004 and then Has_Discriminants (Full_View (T1))
5006 return Subtypes_Statically_Match (Full_View (T1), T2);
5017 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
5018 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
5026 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
5030 -- Now loop through the discriminant constraints
5032 -- Note: the guard here seems necessary, since it is possible at
5033 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5035 if Present (DL1) and then Present (DL2) then
5036 DA1 := First_Elmt (DL1);
5037 DA2 := First_Elmt (DL2);
5038 while Present (DA1) loop
5040 Expr1 : constant Node_Id := Node (DA1);
5041 Expr2 : constant Node_Id := Node (DA2);
5044 if not Is_Static_Expression (Expr1)
5045 or else not Is_Static_Expression (Expr2)
5049 -- If either expression raised a constraint error,
5050 -- consider the expressions as matching, since this
5051 -- helps to prevent cascading errors.
5053 elsif Raises_Constraint_Error (Expr1)
5054 or else Raises_Constraint_Error (Expr2)
5058 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
5071 -- A definite type does not match an indefinite or classwide type.
5072 -- However, a generic type with unknown discriminants may be
5073 -- instantiated with a type with no discriminants, and conformance
5074 -- checking on an inherited operation may compare the actual with the
5075 -- subtype that renames it in the instance.
5077 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
5080 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
5084 elsif Is_Array_Type (T1) then
5086 -- If either subtype is unconstrained then both must be, and if both
5087 -- are unconstrained then no further checking is needed.
5089 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
5090 return not (Is_Constrained (T1) or else Is_Constrained (T2));
5093 -- Both subtypes are constrained, so check that the index subtypes
5094 -- statically match.
5097 Index1 : Node_Id := First_Index (T1);
5098 Index2 : Node_Id := First_Index (T2);
5101 while Present (Index1) loop
5103 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
5108 Next_Index (Index1);
5109 Next_Index (Index2);
5115 elsif Is_Access_Type (T1) then
5116 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
5119 elsif Ekind_In (T1, E_Access_Subprogram_Type,
5120 E_Anonymous_Access_Subprogram_Type)
5124 (Designated_Type (T1),
5125 Designated_Type (T2));
5128 Subtypes_Statically_Match
5129 (Designated_Type (T1),
5130 Designated_Type (T2))
5131 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
5134 -- All other types definitely match
5139 end Subtypes_Statically_Match;
5145 function Test (Cond : Boolean) return Uint is
5154 ---------------------------------
5155 -- Test_Expression_Is_Foldable --
5156 ---------------------------------
5160 procedure Test_Expression_Is_Foldable
5170 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
5174 -- If operand is Any_Type, just propagate to result and do not
5175 -- try to fold, this prevents cascaded errors.
5177 if Etype (Op1) = Any_Type then
5178 Set_Etype (N, Any_Type);
5181 -- If operand raises constraint error, then replace node N with the
5182 -- raise constraint error node, and we are obviously not foldable.
5183 -- Note that this replacement inherits the Is_Static_Expression flag
5184 -- from the operand.
5186 elsif Raises_Constraint_Error (Op1) then
5187 Rewrite_In_Raise_CE (N, Op1);
5190 -- If the operand is not static, then the result is not static, and
5191 -- all we have to do is to check the operand since it is now known
5192 -- to appear in a non-static context.
5194 elsif not Is_Static_Expression (Op1) then
5195 Check_Non_Static_Context (Op1);
5196 Fold := Compile_Time_Known_Value (Op1);
5199 -- An expression of a formal modular type is not foldable because
5200 -- the modulus is unknown.
5202 elsif Is_Modular_Integer_Type (Etype (Op1))
5203 and then Is_Generic_Type (Etype (Op1))
5205 Check_Non_Static_Context (Op1);
5208 -- Here we have the case of an operand whose type is OK, which is
5209 -- static, and which does not raise constraint error, we can fold.
5212 Set_Is_Static_Expression (N);
5216 end Test_Expression_Is_Foldable;
5220 procedure Test_Expression_Is_Foldable
5226 CRT_Safe : Boolean := False)
5228 Rstat : constant Boolean := Is_Static_Expression (Op1)
5230 Is_Static_Expression (Op2);
5236 -- Inhibit folding if -gnatd.f flag set
5238 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
5242 -- If either operand is Any_Type, just propagate to result and
5243 -- do not try to fold, this prevents cascaded errors.
5245 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
5246 Set_Etype (N, Any_Type);
5249 -- If left operand raises constraint error, then replace node N with the
5250 -- Raise_Constraint_Error node, and we are obviously not foldable.
5251 -- Is_Static_Expression is set from the two operands in the normal way,
5252 -- and we check the right operand if it is in a non-static context.
5254 elsif Raises_Constraint_Error (Op1) then
5256 Check_Non_Static_Context (Op2);
5259 Rewrite_In_Raise_CE (N, Op1);
5260 Set_Is_Static_Expression (N, Rstat);
5263 -- Similar processing for the case of the right operand. Note that we
5264 -- don't use this routine for the short-circuit case, so we do not have
5265 -- to worry about that special case here.
5267 elsif Raises_Constraint_Error (Op2) then
5269 Check_Non_Static_Context (Op1);
5272 Rewrite_In_Raise_CE (N, Op2);
5273 Set_Is_Static_Expression (N, Rstat);
5276 -- Exclude expressions of a generic modular type, as above
5278 elsif Is_Modular_Integer_Type (Etype (Op1))
5279 and then Is_Generic_Type (Etype (Op1))
5281 Check_Non_Static_Context (Op1);
5284 -- If result is not static, then check non-static contexts on operands
5285 -- since one of them may be static and the other one may not be static.
5287 elsif not Rstat then
5288 Check_Non_Static_Context (Op1);
5289 Check_Non_Static_Context (Op2);
5292 Fold := CRT_Safe_Compile_Time_Known_Value (Op1)
5293 and then CRT_Safe_Compile_Time_Known_Value (Op2);
5295 Fold := Compile_Time_Known_Value (Op1)
5296 and then Compile_Time_Known_Value (Op2);
5301 -- Else result is static and foldable. Both operands are static, and
5302 -- neither raises constraint error, so we can definitely fold.
5305 Set_Is_Static_Expression (N);
5310 end Test_Expression_Is_Foldable;
5316 function Test_In_Range
5319 Assume_Valid : Boolean;
5320 Fixed_Int : Boolean;
5321 Int_Real : Boolean) return Range_Membership
5326 pragma Warnings (Off, Assume_Valid);
5327 -- For now Assume_Valid is unreferenced since the current implementation
5328 -- always returns Unknown if N is not a compile time known value, but we
5329 -- keep the parameter to allow for future enhancements in which we try
5330 -- to get the information in the variable case as well.
5333 -- Universal types have no range limits, so always in range
5335 if Typ = Universal_Integer or else Typ = Universal_Real then
5338 -- Never known if not scalar type. Don't know if this can actually
5339 -- happen, but our spec allows it, so we must check.
5341 elsif not Is_Scalar_Type (Typ) then
5344 -- Never known if this is a generic type, since the bounds of generic
5345 -- types are junk. Note that if we only checked for static expressions
5346 -- (instead of compile time known values) below, we would not need this
5347 -- check, because values of a generic type can never be static, but they
5348 -- can be known at compile time.
5350 elsif Is_Generic_Type (Typ) then
5353 -- Never known unless we have a compile time known value
5355 elsif not Compile_Time_Known_Value (N) then
5358 -- General processing with a known compile time value
5369 Lo := Type_Low_Bound (Typ);
5370 Hi := Type_High_Bound (Typ);
5372 LB_Known := Compile_Time_Known_Value (Lo);
5373 HB_Known := Compile_Time_Known_Value (Hi);
5375 -- Fixed point types should be considered as such only if flag
5376 -- Fixed_Int is set to False.
5378 if Is_Floating_Point_Type (Typ)
5379 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
5382 Valr := Expr_Value_R (N);
5384 if LB_Known and HB_Known then
5385 if Valr >= Expr_Value_R (Lo)
5387 Valr <= Expr_Value_R (Hi)
5391 return Out_Of_Range;
5394 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
5396 (HB_Known and then Valr > Expr_Value_R (Hi))
5398 return Out_Of_Range;
5405 Val := Expr_Value (N);
5407 if LB_Known and HB_Known then
5408 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
5412 return Out_Of_Range;
5415 elsif (LB_Known and then Val < Expr_Value (Lo))
5417 (HB_Known and then Val > Expr_Value (Hi))
5419 return Out_Of_Range;
5433 procedure To_Bits (U : Uint; B : out Bits) is
5435 for J in 0 .. B'Last loop
5436 B (J) := (U / (2 ** J)) mod 2 /= 0;
5440 --------------------
5441 -- Why_Not_Static --
5442 --------------------
5444 procedure Why_Not_Static (Expr : Node_Id) is
5445 N : constant Node_Id := Original_Node (Expr);
5449 procedure Why_Not_Static_List (L : List_Id);
5450 -- A version that can be called on a list of expressions. Finds all
5451 -- non-static violations in any element of the list.
5453 -------------------------
5454 -- Why_Not_Static_List --
5455 -------------------------
5457 procedure Why_Not_Static_List (L : List_Id) is
5460 if Is_Non_Empty_List (L) then
5462 while Present (N) loop
5467 end Why_Not_Static_List;
5469 -- Start of processing for Why_Not_Static
5472 -- Ignore call on error or empty node
5474 if No (Expr) or else Nkind (Expr) = N_Error then
5478 -- Preprocessing for sub expressions
5480 if Nkind (Expr) in N_Subexpr then
5482 -- Nothing to do if expression is static
5484 if Is_OK_Static_Expression (Expr) then
5488 -- Test for constraint error raised
5490 if Raises_Constraint_Error (Expr) then
5492 ("!expression raises exception, cannot be static (RM 4.9(34))",
5497 -- If no type, then something is pretty wrong, so ignore
5499 Typ := Etype (Expr);
5505 -- Type must be scalar or string type (but allow Bignum, since this
5506 -- is really a scalar type from our point of view in this diagnosis).
5508 if not Is_Scalar_Type (Typ)
5509 and then not Is_String_Type (Typ)
5510 and then not Is_RTE (Typ, RE_Bignum)
5513 ("!static expression must have scalar or string type " &
5519 -- If we got through those checks, test particular node kind
5525 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
5528 if Is_Named_Number (E) then
5531 elsif Ekind (E) = E_Constant then
5533 -- One case we can give a metter message is when we have a
5534 -- string literal created by concatenating an aggregate with
5535 -- an others expression.
5537 Entity_Case : declare
5538 CV : constant Node_Id := Constant_Value (E);
5539 CO : constant Node_Id := Original_Node (CV);
5541 function Is_Aggregate (N : Node_Id) return Boolean;
5542 -- See if node N came from an others aggregate, if so
5543 -- return True and set Error_Msg_Sloc to aggregate.
5549 function Is_Aggregate (N : Node_Id) return Boolean is
5551 if Nkind (Original_Node (N)) = N_Aggregate then
5552 Error_Msg_Sloc := Sloc (Original_Node (N));
5555 elsif Is_Entity_Name (N)
5556 and then Ekind (Entity (N)) = E_Constant
5558 Nkind (Original_Node (Constant_Value (Entity (N)))) =
5562 Sloc (Original_Node (Constant_Value (Entity (N))));
5570 -- Start of processing for Entity_Case
5573 if Is_Aggregate (CV)
5574 or else (Nkind (CO) = N_Op_Concat
5575 and then (Is_Aggregate (Left_Opnd (CO))
5577 Is_Aggregate (Right_Opnd (CO))))
5579 Error_Msg_N ("!aggregate (#) is never static", N);
5581 elsif No (CV) or else not Is_Static_Expression (CV) then
5583 ("!& is not a static constant (RM 4.9(5))", N, E);
5589 ("!& is not static constant or named number "
5590 & "(RM 4.9(5))", N, E);
5595 when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
5596 if Nkind (N) in N_Op_Shift then
5598 ("!shift functions are never static (RM 4.9(6,18))", N);
5600 Why_Not_Static (Left_Opnd (N));
5601 Why_Not_Static (Right_Opnd (N));
5607 Why_Not_Static (Right_Opnd (N));
5609 -- Attribute reference
5611 when N_Attribute_Reference =>
5612 Why_Not_Static_List (Expressions (N));
5614 E := Etype (Prefix (N));
5616 if E = Standard_Void_Type then
5620 -- Special case non-scalar'Size since this is a common error
5622 if Attribute_Name (N) = Name_Size then
5624 ("!size attribute is only static for static scalar type "
5625 & "(RM 4.9(7,8))", N);
5629 elsif Is_Array_Type (E) then
5630 if not Nam_In (Attribute_Name (N), Name_First,
5635 ("!static array attribute must be Length, First, or Last "
5636 & "(RM 4.9(8))", N);
5638 -- Since we know the expression is not-static (we already
5639 -- tested for this, must mean array is not static).
5643 ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
5648 -- Special case generic types, since again this is a common source
5651 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
5653 ("!attribute of generic type is never static "
5654 & "(RM 4.9(7,8))", N);
5656 elsif Is_Static_Subtype (E) then
5659 elsif Is_Scalar_Type (E) then
5661 ("!prefix type for attribute is not static scalar subtype "
5662 & "(RM 4.9(7))", N);
5666 ("!static attribute must apply to array/scalar type "
5667 & "(RM 4.9(7,8))", N);
5672 when N_String_Literal =>
5674 ("!subtype of string literal is non-static (RM 4.9(4))", N);
5676 -- Explicit dereference
5678 when N_Explicit_Dereference =>
5680 ("!explicit dereference is never static (RM 4.9)", N);
5684 when N_Function_Call =>
5685 Why_Not_Static_List (Parameter_Associations (N));
5687 -- Complain about non-static function call unless we have Bignum
5688 -- which means that the underlying expression is really some
5689 -- scalar arithmetic operation.
5691 if not Is_RTE (Typ, RE_Bignum) then
5692 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
5695 -- Parameter assocation (test actual parameter)
5697 when N_Parameter_Association =>
5698 Why_Not_Static (Explicit_Actual_Parameter (N));
5700 -- Indexed component
5702 when N_Indexed_Component =>
5703 Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
5707 when N_Procedure_Call_Statement =>
5708 Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
5710 -- Qualified expression (test expression)
5712 when N_Qualified_Expression =>
5713 Why_Not_Static (Expression (N));
5717 when N_Aggregate | N_Extension_Aggregate =>
5718 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
5723 Why_Not_Static (Low_Bound (N));
5724 Why_Not_Static (High_Bound (N));
5726 -- Range constraint, test range expression
5728 when N_Range_Constraint =>
5729 Why_Not_Static (Range_Expression (N));
5731 -- Subtype indication, test constraint
5733 when N_Subtype_Indication =>
5734 Why_Not_Static (Constraint (N));
5736 -- Selected component
5738 when N_Selected_Component =>
5739 Error_Msg_N ("!selected component is never static (RM 4.9)", N);
5744 Error_Msg_N ("!slice is never static (RM 4.9)", N);
5746 when N_Type_Conversion =>
5747 Why_Not_Static (Expression (N));
5749 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
5750 or else not Is_Static_Subtype (Entity (Subtype_Mark (N)))
5753 ("!static conversion requires static scalar subtype result "
5754 & "(RM 4.9(9))", N);
5757 -- Unchecked type conversion
5759 when N_Unchecked_Type_Conversion =>
5761 ("!unchecked type conversion is never static (RM 4.9)", N);
5763 -- All other cases, no reason to give