1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Eval_Fat; use Eval_Fat;
33 with Exp_Util; use Exp_Util;
34 with Freeze; use Freeze;
36 with Namet; use Namet;
37 with Nmake; use Nmake;
38 with Nlists; use Nlists;
41 with Sem_Aux; use Sem_Aux;
42 with Sem_Cat; use Sem_Cat;
43 with Sem_Ch6; use Sem_Ch6;
44 with Sem_Ch8; use Sem_Ch8;
45 with Sem_Res; use Sem_Res;
46 with Sem_Util; use Sem_Util;
47 with Sem_Type; use Sem_Type;
48 with Sem_Warn; use Sem_Warn;
49 with Sinfo; use Sinfo;
50 with Snames; use Snames;
51 with Stand; use Stand;
52 with Stringt; use Stringt;
53 with Tbuild; use Tbuild;
55 package body Sem_Eval is
57 -----------------------------------------
58 -- Handling of Compile Time Evaluation --
59 -----------------------------------------
61 -- The compile time evaluation of expressions is distributed over several
62 -- Eval_xxx procedures. These procedures are called immediately after
63 -- a subexpression is resolved and is therefore accomplished in a bottom
64 -- up fashion. The flags are synthesized using the following approach.
66 -- Is_Static_Expression is determined by following the detailed rules
67 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
68 -- flag of the operands in many cases.
70 -- Raises_Constraint_Error is set if any of the operands have the flag
71 -- set or if an attempt to compute the value of the current expression
72 -- results in detection of a runtime constraint error.
74 -- As described in the spec, the requirement is that Is_Static_Expression
75 -- be accurately set, and in addition for nodes for which this flag is set,
76 -- Raises_Constraint_Error must also be set. Furthermore a node which has
77 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
78 -- requirement is that the expression value must be precomputed, and the
79 -- node is either a literal, or the name of a constant entity whose value
80 -- is a static expression.
82 -- The general approach is as follows. First compute Is_Static_Expression.
83 -- If the node is not static, then the flag is left off in the node and
84 -- we are all done. Otherwise for a static node, we test if any of the
85 -- operands will raise constraint error, and if so, propagate the flag
86 -- Raises_Constraint_Error to the result node and we are done (since the
87 -- error was already posted at a lower level).
89 -- For the case of a static node whose operands do not raise constraint
90 -- error, we attempt to evaluate the node. If this evaluation succeeds,
91 -- then the node is replaced by the result of this computation. If the
92 -- evaluation raises constraint error, then we rewrite the node with
93 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
94 -- to post appropriate error messages.
100 type Bits is array (Nat range <>) of Boolean;
101 -- Used to convert unsigned (modular) values for folding logical ops
103 -- The following definitions are used to maintain a cache of nodes that
104 -- have compile time known values. The cache is maintained only for
105 -- discrete types (the most common case), and is populated by calls to
106 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
107 -- since it is possible for the status to change (in particular it is
108 -- possible for a node to get replaced by a constraint error node).
110 CV_Bits : constant := 5;
111 -- Number of low order bits of Node_Id value used to reference entries
112 -- in the cache table.
114 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
115 -- Size of cache for compile time values
117 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
119 type CV_Entry is record
124 type CV_Cache_Array is array (CV_Range) of CV_Entry;
126 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
127 -- This is the actual cache, with entries consisting of node/value pairs,
128 -- and the impossible value Node_High_Bound used for unset entries.
130 type Range_Membership is (In_Range, Out_Of_Range, Unknown);
131 -- Range membership may either be statically known to be in range or out
132 -- of range, or not statically known. Used for Test_In_Range below.
134 -----------------------
135 -- Local Subprograms --
136 -----------------------
138 function From_Bits (B : Bits; T : Entity_Id) return Uint;
139 -- Converts a bit string of length B'Length to a Uint value to be used
140 -- for a target of type T, which is a modular type. This procedure
141 -- includes the necessary reduction by the modulus in the case of a
142 -- non-binary modulus (for a binary modulus, the bit string is the
143 -- right length any way so all is well).
145 function Get_String_Val (N : Node_Id) return Node_Id;
146 -- Given a tree node for a folded string or character value, returns
147 -- the corresponding string literal or character literal (one of the
148 -- two must be available, or the operand would not have been marked
149 -- as foldable in the earlier analysis of the operation).
151 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
152 -- Bits represents the number of bits in an integer value to be computed
153 -- (but the value has not been computed yet). If this value in Bits is
154 -- reasonable, a result of True is returned, with the implication that
155 -- the caller should go ahead and complete the calculation. If the value
156 -- in Bits is unreasonably large, then an error is posted on node N, and
157 -- False is returned (and the caller skips the proposed calculation).
159 procedure Out_Of_Range (N : Node_Id);
160 -- This procedure is called if it is determined that node N, which
161 -- appears in a non-static context, is a compile time known value
162 -- which is outside its range, i.e. the range of Etype. This is used
163 -- in contexts where this is an illegality if N is static, and should
164 -- generate a warning otherwise.
166 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
167 -- N and Exp are nodes representing an expression, Exp is known
168 -- to raise CE. N is rewritten in term of Exp in the optimal way.
170 function String_Type_Len (Stype : Entity_Id) return Uint;
171 -- Given a string type, determines the length of the index type, or,
172 -- if this index type is non-static, the length of the base type of
173 -- this index type. Note that if the string type is itself static,
174 -- then the index type is static, so the second case applies only
175 -- if the string type passed is non-static.
177 function Test (Cond : Boolean) return Uint;
178 pragma Inline (Test);
179 -- This function simply returns the appropriate Boolean'Pos value
180 -- corresponding to the value of Cond as a universal integer. It is
181 -- used for producing the result of the static evaluation of the
184 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
185 -- Check whether an arithmetic operation with universal operands which
186 -- is a rewritten function call with an explicit scope indication is
187 -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one
188 -- visible numeric type declared in P and the context does not impose a
189 -- type on the result (e.g. in the expression of a type conversion).
190 -- If ambiguous, emit an error and return Empty, else return the result
191 -- type of the operator.
193 procedure Test_Expression_Is_Foldable
198 -- Tests to see if expression N whose single operand is Op1 is foldable,
199 -- i.e. the operand value is known at compile time. If the operation is
200 -- foldable, then Fold is True on return, and Stat indicates whether
201 -- the result is static (i.e. both operands were static). Note that it
202 -- is quite possible for Fold to be True, and Stat to be False, since
203 -- there are cases in which we know the value of an operand even though
204 -- it is not technically static (e.g. the static lower bound of a range
205 -- whose upper bound is non-static).
207 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes a
208 -- call to Check_Non_Static_Context on the operand. If Fold is False on
209 -- return, then all processing is complete, and the caller should
210 -- return, since there is nothing else to do.
212 -- If Stat is set True on return, then Is_Static_Expression is also set
213 -- true in node N. There are some cases where this is over-enthusiastic,
214 -- e.g. in the two operand case below, for string comparison, the result
215 -- is not static even though the two operands are static. In such cases,
216 -- the caller must reset the Is_Static_Expression flag in N.
218 procedure Test_Expression_Is_Foldable
224 -- Same processing, except applies to an expression N with two operands
227 function Test_In_Range
230 Assume_Valid : Boolean;
232 Int_Real : Boolean) return Range_Membership;
233 -- Common processing for Is_In_Range and Is_Out_Of_Range:
234 -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time
235 -- that expression N is known to be in or out of range of the subtype Typ.
236 -- If not compile time known, Unknown is returned.
237 -- See documentation of Is_In_Range for complete description of parameters.
239 procedure To_Bits (U : Uint; B : out Bits);
240 -- Converts a Uint value to a bit string of length B'Length
242 ------------------------------
243 -- Check_Non_Static_Context --
244 ------------------------------
246 procedure Check_Non_Static_Context (N : Node_Id) is
247 T : constant Entity_Id := Etype (N);
248 Checks_On : constant Boolean :=
249 not Index_Checks_Suppressed (T)
250 and not Range_Checks_Suppressed (T);
253 -- Ignore cases of non-scalar types, error types, or universal real
254 -- types that have no usable bounds.
257 or else not Is_Scalar_Type (T)
258 or else T = Universal_Fixed
259 or else T = Universal_Real
264 -- At this stage we have a scalar type. If we have an expression that
265 -- raises CE, then we already issued a warning or error msg so there
266 -- is nothing more to be done in this routine.
268 if Raises_Constraint_Error (N) then
272 -- Now we have a scalar type which is not marked as raising a constraint
273 -- error exception. The main purpose of this routine is to deal with
274 -- static expressions appearing in a non-static context. That means
275 -- that if we do not have a static expression then there is not much
276 -- to do. The one case that we deal with here is that if we have a
277 -- floating-point value that is out of range, then we post a warning
278 -- that an infinity will result.
280 if not Is_Static_Expression (N) then
281 if Is_Floating_Point_Type (T)
282 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
285 ("?float value out of range, infinity will be generated", N);
291 -- Here we have the case of outer level static expression of scalar
292 -- type, where the processing of this procedure is needed.
294 -- For real types, this is where we convert the value to a machine
295 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
296 -- need to do this if the parent is a constant declaration, since in
297 -- other cases, gigi should do the necessary conversion correctly, but
298 -- experimentation shows that this is not the case on all machines, in
299 -- particular if we do not convert all literals to machine values in
300 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
303 if Nkind (N) = N_Real_Literal
304 and then not Is_Machine_Number (N)
305 and then not Is_Generic_Type (Etype (N))
306 and then Etype (N) /= Universal_Real
308 -- Check that value is in bounds before converting to machine
309 -- number, so as not to lose case where value overflows in the
310 -- least significant bit or less. See B490001.
312 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
317 -- Note: we have to copy the node, to avoid problems with conformance
318 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
320 Rewrite (N, New_Copy (N));
322 if not Is_Floating_Point_Type (T) then
324 (N, Corresponding_Integer_Value (N) * Small_Value (T));
326 elsif not UR_Is_Zero (Realval (N)) then
328 -- Note: even though RM 4.9(38) specifies biased rounding, this
329 -- has been modified by AI-100 in order to prevent confusing
330 -- differences in rounding between static and non-static
331 -- expressions. AI-100 specifies that the effect of such rounding
332 -- is implementation dependent, and in GNAT we round to nearest
333 -- even to match the run-time behavior.
336 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
339 Set_Is_Machine_Number (N);
342 -- Check for out of range universal integer. This is a non-static
343 -- context, so the integer value must be in range of the runtime
344 -- representation of universal integers.
346 -- We do this only within an expression, because that is the only
347 -- case in which non-static universal integer values can occur, and
348 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
349 -- called in contexts like the expression of a number declaration where
350 -- we certainly want to allow out of range values.
352 if Etype (N) = Universal_Integer
353 and then Nkind (N) = N_Integer_Literal
354 and then Nkind (Parent (N)) in N_Subexpr
356 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
358 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
360 Apply_Compile_Time_Constraint_Error
361 (N, "non-static universal integer value out of range?",
362 CE_Range_Check_Failed);
364 -- Check out of range of base type
366 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
369 -- Give warning if outside subtype (where one or both of the bounds of
370 -- the subtype is static). This warning is omitted if the expression
371 -- appears in a range that could be null (warnings are handled elsewhere
374 elsif T /= Base_Type (T)
375 and then Nkind (Parent (N)) /= N_Range
377 if Is_In_Range (N, T, Assume_Valid => True) then
380 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
381 Apply_Compile_Time_Constraint_Error
382 (N, "value not in range of}?", CE_Range_Check_Failed);
385 Enable_Range_Check (N);
388 Set_Do_Range_Check (N, False);
391 end Check_Non_Static_Context;
393 ---------------------------------
394 -- Check_String_Literal_Length --
395 ---------------------------------
397 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
399 if not Raises_Constraint_Error (N)
400 and then Is_Constrained (Ttype)
403 UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
405 Apply_Compile_Time_Constraint_Error
406 (N, "string length wrong for}?",
407 CE_Length_Check_Failed,
412 end Check_String_Literal_Length;
414 --------------------------
415 -- Compile_Time_Compare --
416 --------------------------
418 function Compile_Time_Compare
420 Assume_Valid : Boolean) return Compare_Result
422 Discard : aliased Uint;
424 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
425 end Compile_Time_Compare;
427 function Compile_Time_Compare
430 Assume_Valid : Boolean;
431 Rec : Boolean := False) return Compare_Result
433 Ltyp : Entity_Id := Underlying_Type (Etype (L));
434 Rtyp : Entity_Id := Underlying_Type (Etype (R));
435 -- These get reset to the base type for the case of entities where
436 -- Is_Known_Valid is not set. This takes care of handling possible
437 -- invalid representations using the value of the base type, in
438 -- accordance with RM 13.9.1(10).
440 Discard : aliased Uint;
442 procedure Compare_Decompose
446 -- This procedure decomposes the node N into an expression node and a
447 -- signed offset, so that the value of N is equal to the value of R plus
448 -- the value V (which may be negative). If no such decomposition is
449 -- possible, then on return R is a copy of N, and V is set to zero.
451 function Compare_Fixup (N : Node_Id) return Node_Id;
452 -- This function deals with replacing 'Last and 'First references with
453 -- their corresponding type bounds, which we then can compare. The
454 -- argument is the original node, the result is the identity, unless we
455 -- have a 'Last/'First reference in which case the value returned is the
456 -- appropriate type bound.
458 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
459 -- Even if the context does not assume that values are valid, some
460 -- simple cases can be recognized.
462 function Is_Same_Value (L, R : Node_Id) return Boolean;
463 -- Returns True iff L and R represent expressions that definitely have
464 -- identical (but not necessarily compile time known) values Indeed the
465 -- caller is expected to have already dealt with the cases of compile
466 -- time known values, so these are not tested here.
468 -----------------------
469 -- Compare_Decompose --
470 -----------------------
472 procedure Compare_Decompose
478 if Nkind (N) = N_Op_Add
479 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
482 V := Intval (Right_Opnd (N));
485 elsif Nkind (N) = N_Op_Subtract
486 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
489 V := UI_Negate (Intval (Right_Opnd (N)));
492 elsif Nkind (N) = N_Attribute_Reference then
493 if Attribute_Name (N) = Name_Succ then
494 R := First (Expressions (N));
498 elsif Attribute_Name (N) = Name_Pred then
499 R := First (Expressions (N));
507 end Compare_Decompose;
513 function Compare_Fixup (N : Node_Id) return Node_Id is
519 if Nkind (N) = N_Attribute_Reference
520 and then (Attribute_Name (N) = Name_First
522 Attribute_Name (N) = Name_Last)
524 Xtyp := Etype (Prefix (N));
526 -- If we have no type, then just abandon the attempt to do
527 -- a fixup, this is probably the result of some other error.
533 -- Dereference an access type
535 if Is_Access_Type (Xtyp) then
536 Xtyp := Designated_Type (Xtyp);
539 -- If we don't have an array type at this stage, something
540 -- is peculiar, e.g. another error, and we abandon the attempt
543 if not Is_Array_Type (Xtyp) then
547 -- Ignore unconstrained array, since bounds are not meaningful
549 if not Is_Constrained (Xtyp) then
553 if Ekind (Xtyp) = E_String_Literal_Subtype then
554 if Attribute_Name (N) = Name_First then
555 return String_Literal_Low_Bound (Xtyp);
557 else -- Attribute_Name (N) = Name_Last
558 return Make_Integer_Literal (Sloc (N),
559 Intval => Intval (String_Literal_Low_Bound (Xtyp))
560 + String_Literal_Length (Xtyp));
564 -- Find correct index type
566 Indx := First_Index (Xtyp);
568 if Present (Expressions (N)) then
569 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
571 for J in 2 .. Subs loop
572 Indx := Next_Index (Indx);
576 Xtyp := Etype (Indx);
578 if Attribute_Name (N) = Name_First then
579 return Type_Low_Bound (Xtyp);
581 else -- Attribute_Name (N) = Name_Last
582 return Type_High_Bound (Xtyp);
589 ----------------------------
590 -- Is_Known_Valid_Operand --
591 ----------------------------
593 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
595 return (Is_Entity_Name (Opnd)
597 (Is_Known_Valid (Entity (Opnd))
598 or else Ekind (Entity (Opnd)) = E_In_Parameter
600 (Ekind (Entity (Opnd)) in Object_Kind
601 and then Present (Current_Value (Entity (Opnd))))))
602 or else Is_OK_Static_Expression (Opnd);
603 end Is_Known_Valid_Operand;
609 function Is_Same_Value (L, R : Node_Id) return Boolean is
610 Lf : constant Node_Id := Compare_Fixup (L);
611 Rf : constant Node_Id := Compare_Fixup (R);
613 function Is_Same_Subscript (L, R : List_Id) return Boolean;
614 -- L, R are the Expressions values from two attribute nodes for First
615 -- or Last attributes. Either may be set to No_List if no expressions
616 -- are present (indicating subscript 1). The result is True if both
617 -- expressions represent the same subscript (note one case is where
618 -- one subscript is missing and the other is explicitly set to 1).
620 -----------------------
621 -- Is_Same_Subscript --
622 -----------------------
624 function Is_Same_Subscript (L, R : List_Id) return Boolean is
630 return Expr_Value (First (R)) = Uint_1;
635 return Expr_Value (First (L)) = Uint_1;
637 return Expr_Value (First (L)) = Expr_Value (First (R));
640 end Is_Same_Subscript;
642 -- Start of processing for Is_Same_Value
645 -- Values are the same if they refer to the same entity and the
646 -- entity is non-volatile. This does not however apply to Float
647 -- types, since we may have two NaN values and they should never
650 -- If the entity is a discriminant, the two expressions may be bounds
651 -- of components of objects of the same discriminated type. The
652 -- values of the discriminants are not static, and therefore the
653 -- result is unknown.
655 -- It would be better to comment individual branches of this test ???
657 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
658 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
659 and then Entity (Lf) = Entity (Rf)
660 and then Ekind (Entity (Lf)) /= E_Discriminant
661 and then Present (Entity (Lf))
662 and then not Is_Floating_Point_Type (Etype (L))
663 and then not Is_Volatile_Reference (L)
664 and then not Is_Volatile_Reference (R)
668 -- Or if they are compile time known and identical
670 elsif Compile_Time_Known_Value (Lf)
672 Compile_Time_Known_Value (Rf)
673 and then Expr_Value (Lf) = Expr_Value (Rf)
677 -- False if Nkind of the two nodes is different for remaining cases
679 elsif Nkind (Lf) /= Nkind (Rf) then
682 -- True if both 'First or 'Last values applying to the same entity
683 -- (first and last don't change even if value does). Note that we
684 -- need this even with the calls to Compare_Fixup, to handle the
685 -- case of unconstrained array attributes where Compare_Fixup
686 -- cannot find useful bounds.
688 elsif Nkind (Lf) = N_Attribute_Reference
689 and then Attribute_Name (Lf) = Attribute_Name (Rf)
690 and then (Attribute_Name (Lf) = Name_First
692 Attribute_Name (Lf) = Name_Last)
693 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
694 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
695 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
696 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
700 -- True if the same selected component from the same record
702 elsif Nkind (Lf) = N_Selected_Component
703 and then Selector_Name (Lf) = Selector_Name (Rf)
704 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
708 -- True if the same unary operator applied to the same operand
710 elsif Nkind (Lf) in N_Unary_Op
711 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
715 -- True if the same binary operator applied to the same operands
717 elsif Nkind (Lf) in N_Binary_Op
718 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
719 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
723 -- All other cases, we can't tell, so return False
730 -- Start of processing for Compile_Time_Compare
735 -- If either operand could raise constraint error, then we cannot
736 -- know the result at compile time (since CE may be raised!)
738 if not (Cannot_Raise_Constraint_Error (L)
740 Cannot_Raise_Constraint_Error (R))
745 -- Identical operands are most certainly equal
750 -- If expressions have no types, then do not attempt to determine if
751 -- they are the same, since something funny is going on. One case in
752 -- which this happens is during generic template analysis, when bounds
753 -- are not fully analyzed.
755 elsif No (Ltyp) or else No (Rtyp) then
758 -- We do not attempt comparisons for packed arrays arrays represented as
759 -- modular types, where the semantics of comparison is quite different.
761 elsif Is_Packed_Array_Type (Ltyp)
762 and then Is_Modular_Integer_Type (Ltyp)
766 -- For access types, the only time we know the result at compile time
767 -- (apart from identical operands, which we handled already) is if we
768 -- know one operand is null and the other is not, or both operands are
771 elsif Is_Access_Type (Ltyp) then
772 if Known_Null (L) then
773 if Known_Null (R) then
775 elsif Known_Non_Null (R) then
781 elsif Known_Non_Null (L) and then Known_Null (R) then
788 -- Case where comparison involves two compile time known values
790 elsif Compile_Time_Known_Value (L)
791 and then Compile_Time_Known_Value (R)
793 -- For the floating-point case, we have to be a little careful, since
794 -- at compile time we are dealing with universal exact values, but at
795 -- runtime, these will be in non-exact target form. That's why the
796 -- returned results are LE and GE below instead of LT and GT.
798 if Is_Floating_Point_Type (Ltyp)
800 Is_Floating_Point_Type (Rtyp)
803 Lo : constant Ureal := Expr_Value_R (L);
804 Hi : constant Ureal := Expr_Value_R (R);
816 -- For string types, we have two string literals and we proceed to
817 -- compare them using the Ada style dictionary string comparison.
819 elsif not Is_Scalar_Type (Ltyp) then
821 Lstring : constant String_Id := Strval (Expr_Value_S (L));
822 Rstring : constant String_Id := Strval (Expr_Value_S (R));
823 Llen : constant Nat := String_Length (Lstring);
824 Rlen : constant Nat := String_Length (Rstring);
827 for J in 1 .. Nat'Min (Llen, Rlen) loop
829 LC : constant Char_Code := Get_String_Char (Lstring, J);
830 RC : constant Char_Code := Get_String_Char (Rstring, J);
842 elsif Llen > Rlen then
849 -- For remaining scalar cases we know exactly (note that this does
850 -- include the fixed-point case, where we know the run time integer
855 Lo : constant Uint := Expr_Value (L);
856 Hi : constant Uint := Expr_Value (R);
873 -- Cases where at least one operand is not known at compile time
876 -- Remaining checks apply only for discrete types
878 if not Is_Discrete_Type (Ltyp)
879 or else not Is_Discrete_Type (Rtyp)
884 -- Defend against generic types, or actually any expressions that
885 -- contain a reference to a generic type from within a generic
886 -- template. We don't want to do any range analysis of such
887 -- expressions for two reasons. First, the bounds of a generic type
888 -- itself are junk and cannot be used for any kind of analysis.
889 -- Second, we may have a case where the range at run time is indeed
890 -- known, but we don't want to do compile time analysis in the
891 -- template based on that range since in an instance the value may be
892 -- static, and able to be elaborated without reference to the bounds
893 -- of types involved. As an example, consider:
895 -- (F'Pos (F'Last) + 1) > Integer'Last
897 -- The expression on the left side of > is Universal_Integer and thus
898 -- acquires the type Integer for evaluation at run time, and at run
899 -- time it is true that this condition is always False, but within
900 -- an instance F may be a type with a static range greater than the
901 -- range of Integer, and the expression statically evaluates to True.
903 if References_Generic_Formal_Type (L)
905 References_Generic_Formal_Type (R)
910 -- Replace types by base types for the case of entities which are
911 -- not known to have valid representations. This takes care of
912 -- properly dealing with invalid representations.
914 if not Assume_Valid and then not Assume_No_Invalid_Values then
915 if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
916 Ltyp := Underlying_Type (Base_Type (Ltyp));
919 if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
920 Rtyp := Underlying_Type (Base_Type (Rtyp));
924 -- Try range analysis on variables and see if ranges are disjoint
932 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
933 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
947 -- If the range includes a single literal and we can assume
948 -- validity then the result is known even if an operand is
963 elsif not Is_Known_Valid_Operand (L)
964 and then not Assume_Valid
966 if Is_Same_Value (L, R) then
973 -- If the range of either operand cannot be determined, nothing
974 -- further can be inferred.
981 -- Here is where we check for comparisons against maximum bounds of
982 -- types, where we know that no value can be outside the bounds of
983 -- the subtype. Note that this routine is allowed to assume that all
984 -- expressions are within their subtype bounds. Callers wishing to
985 -- deal with possibly invalid values must in any case take special
986 -- steps (e.g. conversions to larger types) to avoid this kind of
987 -- optimization, which is always considered to be valid. We do not
988 -- attempt this optimization with generic types, since the type
989 -- bounds may not be meaningful in this case.
991 -- We are in danger of an infinite recursion here. It does not seem
992 -- useful to go more than one level deep, so the parameter Rec is
993 -- used to protect ourselves against this infinite recursion.
997 -- See if we can get a decisive check against one operand and
998 -- a bound of the other operand (four possible tests here).
999 -- Note that we avoid testing junk bounds of a generic type.
1001 if not Is_Generic_Type (Rtyp) then
1002 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1004 Assume_Valid, Rec => True)
1006 when LT => return LT;
1007 when LE => return LE;
1008 when EQ => return LE;
1009 when others => null;
1012 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1014 Assume_Valid, Rec => True)
1016 when GT => return GT;
1017 when GE => return GE;
1018 when EQ => return GE;
1019 when others => null;
1023 if not Is_Generic_Type (Ltyp) then
1024 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1026 Assume_Valid, Rec => True)
1028 when GT => return GT;
1029 when GE => return GE;
1030 when EQ => return GE;
1031 when others => null;
1034 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1036 Assume_Valid, Rec => True)
1038 when LT => return LT;
1039 when LE => return LE;
1040 when EQ => return LE;
1041 when others => null;
1046 -- Next attempt is to decompose the expressions to extract
1047 -- a constant offset resulting from the use of any of the forms:
1054 -- Then we see if the two expressions are the same value, and if so
1055 -- the result is obtained by comparing the offsets.
1064 Compare_Decompose (L, Lnode, Loffs);
1065 Compare_Decompose (R, Rnode, Roffs);
1067 if Is_Same_Value (Lnode, Rnode) then
1068 if Loffs = Roffs then
1071 elsif Loffs < Roffs then
1072 Diff.all := Roffs - Loffs;
1076 Diff.all := Loffs - Roffs;
1082 -- Next attempt is to see if we have an entity compared with a
1083 -- compile time known value, where there is a current value
1084 -- conditional for the entity which can tell us the result.
1088 -- Entity variable (left operand)
1091 -- Value (right operand)
1094 -- If False, we have reversed the operands
1097 -- Comparison operator kind from Get_Current_Value_Condition call
1100 -- Value from Get_Current_Value_Condition call
1105 Result : Compare_Result;
1106 -- Known result before inversion
1109 if Is_Entity_Name (L)
1110 and then Compile_Time_Known_Value (R)
1113 Val := Expr_Value (R);
1116 elsif Is_Entity_Name (R)
1117 and then Compile_Time_Known_Value (L)
1120 Val := Expr_Value (L);
1123 -- That was the last chance at finding a compile time result
1129 Get_Current_Value_Condition (Var, Op, Opn);
1131 -- That was the last chance, so if we got nothing return
1137 Opv := Expr_Value (Opn);
1139 -- We got a comparison, so we might have something interesting
1141 -- Convert LE to LT and GE to GT, just so we have fewer cases
1143 if Op = N_Op_Le then
1147 elsif Op = N_Op_Ge then
1152 -- Deal with equality case
1154 if Op = N_Op_Eq then
1157 elsif Opv < Val then
1163 -- Deal with inequality case
1165 elsif Op = N_Op_Ne then
1172 -- Deal with greater than case
1174 elsif Op = N_Op_Gt then
1177 elsif Opv = Val - 1 then
1183 -- Deal with less than case
1185 else pragma Assert (Op = N_Op_Lt);
1188 elsif Opv = Val + 1 then
1195 -- Deal with inverting result
1199 when GT => return LT;
1200 when GE => return LE;
1201 when LT => return GT;
1202 when LE => return GE;
1203 when others => return Result;
1210 end Compile_Time_Compare;
1212 -------------------------------
1213 -- Compile_Time_Known_Bounds --
1214 -------------------------------
1216 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1221 if not Is_Array_Type (T) then
1225 Indx := First_Index (T);
1226 while Present (Indx) loop
1227 Typ := Underlying_Type (Etype (Indx));
1229 -- Never look at junk bounds of a generic type
1231 if Is_Generic_Type (Typ) then
1235 -- Otherwise check bounds for compile time known
1237 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1239 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1247 end Compile_Time_Known_Bounds;
1249 ------------------------------
1250 -- Compile_Time_Known_Value --
1251 ------------------------------
1253 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1254 K : constant Node_Kind := Nkind (Op);
1255 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1258 -- Never known at compile time if bad type or raises constraint error
1259 -- or empty (latter case occurs only as a result of a previous error)
1263 or else Etype (Op) = Any_Type
1264 or else Raises_Constraint_Error (Op)
1269 -- If this is not a static expression or a null literal, and we are in
1270 -- configurable run-time mode, then we consider it not known at compile
1271 -- time. This avoids anomalies where whether something is allowed with a
1272 -- given configurable run-time library depends on how good the compiler
1273 -- is at optimizing and knowing that things are constant when they are
1276 if Configurable_Run_Time_Mode
1277 and then K /= N_Null
1278 and then not Is_Static_Expression (Op)
1283 -- If we have an entity name, then see if it is the name of a constant
1284 -- and if so, test the corresponding constant value, or the name of
1285 -- an enumeration literal, which is always a constant.
1287 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1289 E : constant Entity_Id := Entity (Op);
1293 -- Never known at compile time if it is a packed array value.
1294 -- We might want to try to evaluate these at compile time one
1295 -- day, but we do not make that attempt now.
1297 if Is_Packed_Array_Type (Etype (Op)) then
1301 if Ekind (E) = E_Enumeration_Literal then
1304 elsif Ekind (E) = E_Constant then
1305 V := Constant_Value (E);
1306 return Present (V) and then Compile_Time_Known_Value (V);
1310 -- We have a value, see if it is compile time known
1313 -- Integer literals are worth storing in the cache
1315 if K = N_Integer_Literal then
1317 CV_Ent.V := Intval (Op);
1320 -- Other literals and NULL are known at compile time
1323 K = N_Character_Literal
1327 K = N_String_Literal
1333 -- Any reference to Null_Parameter is known at compile time. No
1334 -- other attribute references (that have not already been folded)
1335 -- are known at compile time.
1337 elsif K = N_Attribute_Reference then
1338 return Attribute_Name (Op) = Name_Null_Parameter;
1342 -- If we fall through, not known at compile time
1346 -- If we get an exception while trying to do this test, then some error
1347 -- has occurred, and we simply say that the value is not known after all
1352 end Compile_Time_Known_Value;
1354 --------------------------------------
1355 -- Compile_Time_Known_Value_Or_Aggr --
1356 --------------------------------------
1358 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1360 -- If we have an entity name, then see if it is the name of a constant
1361 -- and if so, test the corresponding constant value, or the name of
1362 -- an enumeration literal, which is always a constant.
1364 if Is_Entity_Name (Op) then
1366 E : constant Entity_Id := Entity (Op);
1370 if Ekind (E) = E_Enumeration_Literal then
1373 elsif Ekind (E) /= E_Constant then
1377 V := Constant_Value (E);
1379 and then Compile_Time_Known_Value_Or_Aggr (V);
1383 -- We have a value, see if it is compile time known
1386 if Compile_Time_Known_Value (Op) then
1389 elsif Nkind (Op) = N_Aggregate then
1391 if Present (Expressions (Op)) then
1396 Expr := First (Expressions (Op));
1397 while Present (Expr) loop
1398 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1407 if Present (Component_Associations (Op)) then
1412 Cass := First (Component_Associations (Op));
1413 while Present (Cass) loop
1415 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1427 -- All other types of values are not known at compile time
1434 end Compile_Time_Known_Value_Or_Aggr;
1440 -- This is only called for actuals of functions that are not predefined
1441 -- operators (which have already been rewritten as operators at this
1442 -- stage), so the call can never be folded, and all that needs doing for
1443 -- the actual is to do the check for a non-static context.
1445 procedure Eval_Actual (N : Node_Id) is
1447 Check_Non_Static_Context (N);
1450 --------------------
1451 -- Eval_Allocator --
1452 --------------------
1454 -- Allocators are never static, so all we have to do is to do the
1455 -- check for a non-static context if an expression is present.
1457 procedure Eval_Allocator (N : Node_Id) is
1458 Expr : constant Node_Id := Expression (N);
1461 if Nkind (Expr) = N_Qualified_Expression then
1462 Check_Non_Static_Context (Expression (Expr));
1466 ------------------------
1467 -- Eval_Arithmetic_Op --
1468 ------------------------
1470 -- Arithmetic operations are static functions, so the result is static
1471 -- if both operands are static (RM 4.9(7), 4.9(20)).
1473 procedure Eval_Arithmetic_Op (N : Node_Id) is
1474 Left : constant Node_Id := Left_Opnd (N);
1475 Right : constant Node_Id := Right_Opnd (N);
1476 Ltype : constant Entity_Id := Etype (Left);
1477 Rtype : constant Entity_Id := Etype (Right);
1478 Otype : Entity_Id := Empty;
1483 -- If not foldable we are done
1485 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1491 if Is_Universal_Numeric_Type (Etype (Left))
1493 Is_Universal_Numeric_Type (Etype (Right))
1495 Otype := Find_Universal_Operator_Type (N);
1498 -- Fold for cases where both operands are of integer type
1500 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1502 Left_Int : constant Uint := Expr_Value (Left);
1503 Right_Int : constant Uint := Expr_Value (Right);
1510 Result := Left_Int + Right_Int;
1512 when N_Op_Subtract =>
1513 Result := Left_Int - Right_Int;
1515 when N_Op_Multiply =>
1518 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1520 Result := Left_Int * Right_Int;
1527 -- The exception Constraint_Error is raised by integer
1528 -- division, rem and mod if the right operand is zero.
1530 if Right_Int = 0 then
1531 Apply_Compile_Time_Constraint_Error
1532 (N, "division by zero",
1538 Result := Left_Int / Right_Int;
1543 -- The exception Constraint_Error is raised by integer
1544 -- division, rem and mod if the right operand is zero.
1546 if Right_Int = 0 then
1547 Apply_Compile_Time_Constraint_Error
1548 (N, "mod with zero divisor",
1553 Result := Left_Int mod Right_Int;
1558 -- The exception Constraint_Error is raised by integer
1559 -- division, rem and mod if the right operand is zero.
1561 if Right_Int = 0 then
1562 Apply_Compile_Time_Constraint_Error
1563 (N, "rem with zero divisor",
1569 Result := Left_Int rem Right_Int;
1573 raise Program_Error;
1576 -- Adjust the result by the modulus if the type is a modular type
1578 if Is_Modular_Integer_Type (Ltype) then
1579 Result := Result mod Modulus (Ltype);
1581 -- For a signed integer type, check non-static overflow
1583 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1585 BT : constant Entity_Id := Base_Type (Ltype);
1586 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1587 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1589 if Result < Lo or else Result > Hi then
1590 Apply_Compile_Time_Constraint_Error
1591 (N, "value not in range of }?",
1592 CE_Overflow_Check_Failed,
1599 -- If we get here we can fold the result
1601 Fold_Uint (N, Result, Stat);
1604 -- Cases where at least one operand is a real. We handle the cases of
1605 -- both reals, or mixed/real integer cases (the latter happen only for
1606 -- divide and multiply, and the result is always real).
1608 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1615 if Is_Real_Type (Ltype) then
1616 Left_Real := Expr_Value_R (Left);
1618 Left_Real := UR_From_Uint (Expr_Value (Left));
1621 if Is_Real_Type (Rtype) then
1622 Right_Real := Expr_Value_R (Right);
1624 Right_Real := UR_From_Uint (Expr_Value (Right));
1627 if Nkind (N) = N_Op_Add then
1628 Result := Left_Real + Right_Real;
1630 elsif Nkind (N) = N_Op_Subtract then
1631 Result := Left_Real - Right_Real;
1633 elsif Nkind (N) = N_Op_Multiply then
1634 Result := Left_Real * Right_Real;
1636 else pragma Assert (Nkind (N) = N_Op_Divide);
1637 if UR_Is_Zero (Right_Real) then
1638 Apply_Compile_Time_Constraint_Error
1639 (N, "division by zero", CE_Divide_By_Zero);
1643 Result := Left_Real / Right_Real;
1646 Fold_Ureal (N, Result, Stat);
1650 -- If the operator was resolved to a specific type, make sure that type
1651 -- is frozen even if the expression is folded into a literal (which has
1652 -- a universal type).
1654 if Present (Otype) then
1655 Freeze_Before (N, Otype);
1657 end Eval_Arithmetic_Op;
1659 ----------------------------
1660 -- Eval_Character_Literal --
1661 ----------------------------
1663 -- Nothing to be done!
1665 procedure Eval_Character_Literal (N : Node_Id) is
1666 pragma Warnings (Off, N);
1669 end Eval_Character_Literal;
1675 -- Static function calls are either calls to predefined operators
1676 -- with static arguments, or calls to functions that rename a literal.
1677 -- Only the latter case is handled here, predefined operators are
1678 -- constant-folded elsewhere.
1680 -- If the function is itself inherited (see 7423-001) the literal of
1681 -- the parent type must be explicitly converted to the return type
1684 procedure Eval_Call (N : Node_Id) is
1685 Loc : constant Source_Ptr := Sloc (N);
1686 Typ : constant Entity_Id := Etype (N);
1690 if Nkind (N) = N_Function_Call
1691 and then No (Parameter_Associations (N))
1692 and then Is_Entity_Name (Name (N))
1693 and then Present (Alias (Entity (Name (N))))
1694 and then Is_Enumeration_Type (Base_Type (Typ))
1696 Lit := Ultimate_Alias (Entity (Name (N)));
1698 if Ekind (Lit) = E_Enumeration_Literal then
1699 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
1701 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
1703 Rewrite (N, New_Occurrence_Of (Lit, Loc));
1711 --------------------------
1712 -- Eval_Case_Expression --
1713 --------------------------
1715 -- Right now we do not attempt folding of any case expressions, and the
1716 -- language does not require it, so the only required processing is to
1717 -- do the check for all expressions appearing in the case expression.
1719 procedure Eval_Case_Expression (N : Node_Id) is
1723 Check_Non_Static_Context (Expression (N));
1725 Alt := First (Alternatives (N));
1726 while Present (Alt) loop
1727 Check_Non_Static_Context (Expression (Alt));
1730 end Eval_Case_Expression;
1732 ------------------------
1733 -- Eval_Concatenation --
1734 ------------------------
1736 -- Concatenation is a static function, so the result is static if both
1737 -- operands are static (RM 4.9(7), 4.9(21)).
1739 procedure Eval_Concatenation (N : Node_Id) is
1740 Left : constant Node_Id := Left_Opnd (N);
1741 Right : constant Node_Id := Right_Opnd (N);
1742 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
1747 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
1748 -- non-static context.
1750 if Ada_Version = Ada_83
1751 and then Comes_From_Source (N)
1753 Check_Non_Static_Context (Left);
1754 Check_Non_Static_Context (Right);
1758 -- If not foldable we are done. In principle concatenation that yields
1759 -- any string type is static (i.e. an array type of character types).
1760 -- However, character types can include enumeration literals, and
1761 -- concatenation in that case cannot be described by a literal, so we
1762 -- only consider the operation static if the result is an array of
1763 -- (a descendant of) a predefined character type.
1765 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1767 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
1768 Set_Is_Static_Expression (N, False);
1772 -- Compile time string concatenation
1774 -- ??? Note that operands that are aggregates can be marked as static,
1775 -- so we should attempt at a later stage to fold concatenations with
1779 Left_Str : constant Node_Id := Get_String_Val (Left);
1781 Right_Str : constant Node_Id := Get_String_Val (Right);
1782 Folded_Val : String_Id;
1785 -- Establish new string literal, and store left operand. We make
1786 -- sure to use the special Start_String that takes an operand if
1787 -- the left operand is a string literal. Since this is optimized
1788 -- in the case where that is the most recently created string
1789 -- literal, we ensure efficient time/space behavior for the
1790 -- case of a concatenation of a series of string literals.
1792 if Nkind (Left_Str) = N_String_Literal then
1793 Left_Len := String_Length (Strval (Left_Str));
1795 -- If the left operand is the empty string, and the right operand
1796 -- is a string literal (the case of "" & "..."), the result is the
1797 -- value of the right operand. This optimization is important when
1798 -- Is_Folded_In_Parser, to avoid copying an enormous right
1801 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
1802 Folded_Val := Strval (Right_Str);
1804 Start_String (Strval (Left_Str));
1809 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
1813 -- Now append the characters of the right operand, unless we
1814 -- optimized the "" & "..." case above.
1816 if Nkind (Right_Str) = N_String_Literal then
1817 if Left_Len /= 0 then
1818 Store_String_Chars (Strval (Right_Str));
1819 Folded_Val := End_String;
1822 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
1823 Folded_Val := End_String;
1826 Set_Is_Static_Expression (N, Stat);
1830 -- If left operand is the empty string, the result is the
1831 -- right operand, including its bounds if anomalous.
1834 and then Is_Array_Type (Etype (Right))
1835 and then Etype (Right) /= Any_String
1837 Set_Etype (N, Etype (Right));
1840 Fold_Str (N, Folded_Val, Static => True);
1843 end Eval_Concatenation;
1845 ---------------------------------
1846 -- Eval_Conditional_Expression --
1847 ---------------------------------
1849 -- We can fold to a static expression if the condition and both constituent
1850 -- expressions are static. Otherwise, the only required processing is to do
1851 -- the check for non-static context for the then and else expressions.
1853 procedure Eval_Conditional_Expression (N : Node_Id) is
1854 Condition : constant Node_Id := First (Expressions (N));
1855 Then_Expr : constant Node_Id := Next (Condition);
1856 Else_Expr : constant Node_Id := Next (Then_Expr);
1858 Non_Result : Node_Id;
1860 Rstat : constant Boolean :=
1861 Is_Static_Expression (Condition)
1863 Is_Static_Expression (Then_Expr)
1865 Is_Static_Expression (Else_Expr);
1868 -- If any operand is Any_Type, just propagate to result and do not try
1869 -- to fold, this prevents cascaded errors.
1871 if Etype (Condition) = Any_Type or else
1872 Etype (Then_Expr) = Any_Type or else
1873 Etype (Else_Expr) = Any_Type
1875 Set_Etype (N, Any_Type);
1876 Set_Is_Static_Expression (N, False);
1879 -- Static case where we can fold. Note that we don't try to fold cases
1880 -- where the condition is known at compile time, but the result is
1881 -- non-static. This avoids possible cases of infinite recursion where
1882 -- the expander puts in a redundant test and we remove it. Instead we
1883 -- deal with these cases in the expander.
1887 -- Select result operand
1889 if Is_True (Expr_Value (Condition)) then
1890 Result := Then_Expr;
1891 Non_Result := Else_Expr;
1893 Result := Else_Expr;
1894 Non_Result := Then_Expr;
1897 -- Note that it does not matter if the non-result operand raises a
1898 -- Constraint_Error, but if the result raises constraint error then
1899 -- we replace the node with a raise constraint error. This will
1900 -- properly propagate Raises_Constraint_Error since this flag is
1903 if Raises_Constraint_Error (Result) then
1904 Rewrite_In_Raise_CE (N, Result);
1905 Check_Non_Static_Context (Non_Result);
1907 -- Otherwise the result operand replaces the original node
1910 Rewrite (N, Relocate_Node (Result));
1913 -- Case of condition not known at compile time
1916 Check_Non_Static_Context (Condition);
1917 Check_Non_Static_Context (Then_Expr);
1918 Check_Non_Static_Context (Else_Expr);
1921 Set_Is_Static_Expression (N, Rstat);
1922 end Eval_Conditional_Expression;
1924 ----------------------
1925 -- Eval_Entity_Name --
1926 ----------------------
1928 -- This procedure is used for identifiers and expanded names other than
1929 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1930 -- static if they denote a static constant (RM 4.9(6)) or if the name
1931 -- denotes an enumeration literal (RM 4.9(22)).
1933 procedure Eval_Entity_Name (N : Node_Id) is
1934 Def_Id : constant Entity_Id := Entity (N);
1938 -- Enumeration literals are always considered to be constants
1939 -- and cannot raise constraint error (RM 4.9(22)).
1941 if Ekind (Def_Id) = E_Enumeration_Literal then
1942 Set_Is_Static_Expression (N);
1945 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1946 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1947 -- it does not violate 10.2.1(8) here, since this is not a variable.
1949 elsif Ekind (Def_Id) = E_Constant then
1951 -- Deferred constants must always be treated as nonstatic
1952 -- outside the scope of their full view.
1954 if Present (Full_View (Def_Id))
1955 and then not In_Open_Scopes (Scope (Def_Id))
1959 Val := Constant_Value (Def_Id);
1962 if Present (Val) then
1963 Set_Is_Static_Expression
1964 (N, Is_Static_Expression (Val)
1965 and then Is_Static_Subtype (Etype (Def_Id)));
1966 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1968 if not Is_Static_Expression (N)
1969 and then not Is_Generic_Type (Etype (N))
1971 Validate_Static_Object_Name (N);
1978 -- Fall through if the name is not static
1980 Validate_Static_Object_Name (N);
1981 end Eval_Entity_Name;
1983 ----------------------------
1984 -- Eval_Indexed_Component --
1985 ----------------------------
1987 -- Indexed components are never static, so we need to perform the check
1988 -- for non-static context on the index values. Then, we check if the
1989 -- value can be obtained at compile time, even though it is non-static.
1991 procedure Eval_Indexed_Component (N : Node_Id) is
1995 -- Check for non-static context on index values
1997 Expr := First (Expressions (N));
1998 while Present (Expr) loop
1999 Check_Non_Static_Context (Expr);
2003 -- If the indexed component appears in an object renaming declaration
2004 -- then we do not want to try to evaluate it, since in this case we
2005 -- need the identity of the array element.
2007 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2010 -- Similarly if the indexed component appears as the prefix of an
2011 -- attribute we don't want to evaluate it, because at least for
2012 -- some cases of attributes we need the identify (e.g. Access, Size)
2014 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2018 -- Note: there are other cases, such as the left side of an assignment,
2019 -- or an OUT parameter for a call, where the replacement results in the
2020 -- illegal use of a constant, But these cases are illegal in the first
2021 -- place, so the replacement, though silly, is harmless.
2023 -- Now see if this is a constant array reference
2025 if List_Length (Expressions (N)) = 1
2026 and then Is_Entity_Name (Prefix (N))
2027 and then Ekind (Entity (Prefix (N))) = E_Constant
2028 and then Present (Constant_Value (Entity (Prefix (N))))
2031 Loc : constant Source_Ptr := Sloc (N);
2032 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2033 Sub : constant Node_Id := First (Expressions (N));
2039 -- Linear one's origin subscript value for array reference
2042 -- Lower bound of the first array index
2045 -- Value from constant array
2048 Atyp := Etype (Arr);
2050 if Is_Access_Type (Atyp) then
2051 Atyp := Designated_Type (Atyp);
2054 -- If we have an array type (we should have but perhaps there are
2055 -- error cases where this is not the case), then see if we can do
2056 -- a constant evaluation of the array reference.
2058 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2059 if Ekind (Atyp) = E_String_Literal_Subtype then
2060 Lbd := String_Literal_Low_Bound (Atyp);
2062 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2065 if Compile_Time_Known_Value (Sub)
2066 and then Nkind (Arr) = N_Aggregate
2067 and then Compile_Time_Known_Value (Lbd)
2068 and then Is_Discrete_Type (Component_Type (Atyp))
2070 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2072 if List_Length (Expressions (Arr)) >= Lin then
2073 Elm := Pick (Expressions (Arr), Lin);
2075 -- If the resulting expression is compile time known,
2076 -- then we can rewrite the indexed component with this
2077 -- value, being sure to mark the result as non-static.
2078 -- We also reset the Sloc, in case this generates an
2079 -- error later on (e.g. 136'Access).
2081 if Compile_Time_Known_Value (Elm) then
2082 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2083 Set_Is_Static_Expression (N, False);
2088 -- We can also constant-fold if the prefix is a string literal.
2089 -- This will be useful in an instantiation or an inlining.
2091 elsif Compile_Time_Known_Value (Sub)
2092 and then Nkind (Arr) = N_String_Literal
2093 and then Compile_Time_Known_Value (Lbd)
2094 and then Expr_Value (Lbd) = 1
2095 and then Expr_Value (Sub) <=
2096 String_Literal_Length (Etype (Arr))
2099 C : constant Char_Code :=
2100 Get_String_Char (Strval (Arr),
2101 UI_To_Int (Expr_Value (Sub)));
2103 Set_Character_Literal_Name (C);
2106 Make_Character_Literal (Loc,
2108 Char_Literal_Value => UI_From_CC (C));
2109 Set_Etype (Elm, Component_Type (Atyp));
2110 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2111 Set_Is_Static_Expression (N, False);
2117 end Eval_Indexed_Component;
2119 --------------------------
2120 -- Eval_Integer_Literal --
2121 --------------------------
2123 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2124 -- as static by the analyzer. The reason we did it that early is to allow
2125 -- the possibility of turning off the Is_Static_Expression flag after
2126 -- analysis, but before resolution, when integer literals are generated in
2127 -- the expander that do not correspond to static expressions.
2129 procedure Eval_Integer_Literal (N : Node_Id) is
2130 T : constant Entity_Id := Etype (N);
2132 function In_Any_Integer_Context return Boolean;
2133 -- If the literal is resolved with a specific type in a context where
2134 -- the expected type is Any_Integer, there are no range checks on the
2135 -- literal. By the time the literal is evaluated, it carries the type
2136 -- imposed by the enclosing expression, and we must recover the context
2137 -- to determine that Any_Integer is meant.
2139 ----------------------------
2140 -- In_Any_Integer_Context --
2141 ----------------------------
2143 function In_Any_Integer_Context return Boolean is
2144 Par : constant Node_Id := Parent (N);
2145 K : constant Node_Kind := Nkind (Par);
2148 -- Any_Integer also appears in digits specifications for real types,
2149 -- but those have bounds smaller that those of any integer base type,
2150 -- so we can safely ignore these cases.
2152 return K = N_Number_Declaration
2153 or else K = N_Attribute_Reference
2154 or else K = N_Attribute_Definition_Clause
2155 or else K = N_Modular_Type_Definition
2156 or else K = N_Signed_Integer_Type_Definition;
2157 end In_Any_Integer_Context;
2159 -- Start of processing for Eval_Integer_Literal
2163 -- If the literal appears in a non-expression context, then it is
2164 -- certainly appearing in a non-static context, so check it. This is
2165 -- actually a redundant check, since Check_Non_Static_Context would
2166 -- check it, but it seems worth while avoiding the call.
2168 if Nkind (Parent (N)) not in N_Subexpr
2169 and then not In_Any_Integer_Context
2171 Check_Non_Static_Context (N);
2174 -- Modular integer literals must be in their base range
2176 if Is_Modular_Integer_Type (T)
2177 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2181 end Eval_Integer_Literal;
2183 ---------------------
2184 -- Eval_Logical_Op --
2185 ---------------------
2187 -- Logical operations are static functions, so the result is potentially
2188 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2190 procedure Eval_Logical_Op (N : Node_Id) is
2191 Left : constant Node_Id := Left_Opnd (N);
2192 Right : constant Node_Id := Right_Opnd (N);
2197 -- If not foldable we are done
2199 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2205 -- Compile time evaluation of logical operation
2208 Left_Int : constant Uint := Expr_Value (Left);
2209 Right_Int : constant Uint := Expr_Value (Right);
2212 -- VMS includes bitwise operations on signed types
2214 if Is_Modular_Integer_Type (Etype (N))
2215 or else Is_VMS_Operator (Entity (N))
2218 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2219 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2222 To_Bits (Left_Int, Left_Bits);
2223 To_Bits (Right_Int, Right_Bits);
2225 -- Note: should really be able to use array ops instead of
2226 -- these loops, but they weren't working at the time ???
2228 if Nkind (N) = N_Op_And then
2229 for J in Left_Bits'Range loop
2230 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2233 elsif Nkind (N) = N_Op_Or then
2234 for J in Left_Bits'Range loop
2235 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2239 pragma Assert (Nkind (N) = N_Op_Xor);
2241 for J in Left_Bits'Range loop
2242 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2246 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2250 pragma Assert (Is_Boolean_Type (Etype (N)));
2252 if Nkind (N) = N_Op_And then
2254 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2256 elsif Nkind (N) = N_Op_Or then
2258 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2261 pragma Assert (Nkind (N) = N_Op_Xor);
2263 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2267 end Eval_Logical_Op;
2269 ------------------------
2270 -- Eval_Membership_Op --
2271 ------------------------
2273 -- A membership test is potentially static if the expression is static, and
2274 -- the range is a potentially static range, or is a subtype mark denoting a
2275 -- static subtype (RM 4.9(12)).
2277 procedure Eval_Membership_Op (N : Node_Id) is
2278 Left : constant Node_Id := Left_Opnd (N);
2279 Right : constant Node_Id := Right_Opnd (N);
2288 -- Ignore if error in either operand, except to make sure that Any_Type
2289 -- is properly propagated to avoid junk cascaded errors.
2291 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2292 Set_Etype (N, Any_Type);
2296 -- Ignore if types involved have predicates
2298 if Present (Predicate_Function (Etype (Left)))
2300 Present (Predicate_Function (Etype (Right)))
2305 -- Case of right operand is a subtype name
2307 if Is_Entity_Name (Right) then
2308 Def_Id := Entity (Right);
2310 if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
2311 and then Is_OK_Static_Subtype (Def_Id)
2313 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2315 if not Fold or else not Stat then
2319 Check_Non_Static_Context (Left);
2323 -- For string membership tests we will check the length further on
2325 if not Is_String_Type (Def_Id) then
2326 Lo := Type_Low_Bound (Def_Id);
2327 Hi := Type_High_Bound (Def_Id);
2334 -- Case of right operand is a range
2337 if Is_Static_Range (Right) then
2338 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2340 if not Fold or else not Stat then
2343 -- If one bound of range raises CE, then don't try to fold
2345 elsif not Is_OK_Static_Range (Right) then
2346 Check_Non_Static_Context (Left);
2351 Check_Non_Static_Context (Left);
2355 -- Here we know range is an OK static range
2357 Lo := Low_Bound (Right);
2358 Hi := High_Bound (Right);
2361 -- For strings we check that the length of the string expression is
2362 -- compatible with the string subtype if the subtype is constrained,
2363 -- or if unconstrained then the test is always true.
2365 if Is_String_Type (Etype (Right)) then
2366 if not Is_Constrained (Etype (Right)) then
2371 Typlen : constant Uint := String_Type_Len (Etype (Right));
2372 Strlen : constant Uint :=
2374 (String_Length (Strval (Get_String_Val (Left))));
2376 Result := (Typlen = Strlen);
2380 -- Fold the membership test. We know we have a static range and Lo and
2381 -- Hi are set to the expressions for the end points of this range.
2383 elsif Is_Real_Type (Etype (Right)) then
2385 Leftval : constant Ureal := Expr_Value_R (Left);
2388 Result := Expr_Value_R (Lo) <= Leftval
2389 and then Leftval <= Expr_Value_R (Hi);
2394 Leftval : constant Uint := Expr_Value (Left);
2397 Result := Expr_Value (Lo) <= Leftval
2398 and then Leftval <= Expr_Value (Hi);
2402 if Nkind (N) = N_Not_In then
2403 Result := not Result;
2406 Fold_Uint (N, Test (Result), True);
2408 Warn_On_Known_Condition (N);
2409 end Eval_Membership_Op;
2411 ------------------------
2412 -- Eval_Named_Integer --
2413 ------------------------
2415 procedure Eval_Named_Integer (N : Node_Id) is
2418 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2419 end Eval_Named_Integer;
2421 ---------------------
2422 -- Eval_Named_Real --
2423 ---------------------
2425 procedure Eval_Named_Real (N : Node_Id) is
2428 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2429 end Eval_Named_Real;
2435 -- Exponentiation is a static functions, so the result is potentially
2436 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2438 procedure Eval_Op_Expon (N : Node_Id) is
2439 Left : constant Node_Id := Left_Opnd (N);
2440 Right : constant Node_Id := Right_Opnd (N);
2445 -- If not foldable we are done
2447 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2453 -- Fold exponentiation operation
2456 Right_Int : constant Uint := Expr_Value (Right);
2461 if Is_Integer_Type (Etype (Left)) then
2463 Left_Int : constant Uint := Expr_Value (Left);
2467 -- Exponentiation of an integer raises Constraint_Error for a
2468 -- negative exponent (RM 4.5.6).
2470 if Right_Int < 0 then
2471 Apply_Compile_Time_Constraint_Error
2472 (N, "integer exponent negative",
2473 CE_Range_Check_Failed,
2478 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2479 Result := Left_Int ** Right_Int;
2484 if Is_Modular_Integer_Type (Etype (N)) then
2485 Result := Result mod Modulus (Etype (N));
2488 Fold_Uint (N, Result, Stat);
2496 Left_Real : constant Ureal := Expr_Value_R (Left);
2499 -- Cannot have a zero base with a negative exponent
2501 if UR_Is_Zero (Left_Real) then
2503 if Right_Int < 0 then
2504 Apply_Compile_Time_Constraint_Error
2505 (N, "zero ** negative integer",
2506 CE_Range_Check_Failed,
2510 Fold_Ureal (N, Ureal_0, Stat);
2514 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2525 -- The not operation is a static functions, so the result is potentially
2526 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2528 procedure Eval_Op_Not (N : Node_Id) is
2529 Right : constant Node_Id := Right_Opnd (N);
2534 -- If not foldable we are done
2536 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2542 -- Fold not operation
2545 Rint : constant Uint := Expr_Value (Right);
2546 Typ : constant Entity_Id := Etype (N);
2549 -- Negation is equivalent to subtracting from the modulus minus one.
2550 -- For a binary modulus this is equivalent to the ones-complement of
2551 -- the original value. For non-binary modulus this is an arbitrary
2552 -- but consistent definition.
2554 if Is_Modular_Integer_Type (Typ) then
2555 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2558 pragma Assert (Is_Boolean_Type (Typ));
2559 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2562 Set_Is_Static_Expression (N, Stat);
2566 -------------------------------
2567 -- Eval_Qualified_Expression --
2568 -------------------------------
2570 -- A qualified expression is potentially static if its subtype mark denotes
2571 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2573 procedure Eval_Qualified_Expression (N : Node_Id) is
2574 Operand : constant Node_Id := Expression (N);
2575 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2582 -- Can only fold if target is string or scalar and subtype is static.
2583 -- Also, do not fold if our parent is an allocator (this is because the
2584 -- qualified expression is really part of the syntactic structure of an
2585 -- allocator, and we do not want to end up with something that
2586 -- corresponds to "new 1" where the 1 is the result of folding a
2587 -- qualified expression).
2589 if not Is_Static_Subtype (Target_Type)
2590 or else Nkind (Parent (N)) = N_Allocator
2592 Check_Non_Static_Context (Operand);
2594 -- If operand is known to raise constraint_error, set the flag on the
2595 -- expression so it does not get optimized away.
2597 if Nkind (Operand) = N_Raise_Constraint_Error then
2598 Set_Raises_Constraint_Error (N);
2604 -- If not foldable we are done
2606 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2611 -- Don't try fold if target type has constraint error bounds
2613 elsif not Is_OK_Static_Subtype (Target_Type) then
2614 Set_Raises_Constraint_Error (N);
2618 -- Here we will fold, save Print_In_Hex indication
2620 Hex := Nkind (Operand) = N_Integer_Literal
2621 and then Print_In_Hex (Operand);
2623 -- Fold the result of qualification
2625 if Is_Discrete_Type (Target_Type) then
2626 Fold_Uint (N, Expr_Value (Operand), Stat);
2628 -- Preserve Print_In_Hex indication
2630 if Hex and then Nkind (N) = N_Integer_Literal then
2631 Set_Print_In_Hex (N);
2634 elsif Is_Real_Type (Target_Type) then
2635 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
2638 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
2641 Set_Is_Static_Expression (N, False);
2643 Check_String_Literal_Length (N, Target_Type);
2649 -- The expression may be foldable but not static
2651 Set_Is_Static_Expression (N, Stat);
2653 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
2656 end Eval_Qualified_Expression;
2658 -----------------------
2659 -- Eval_Real_Literal --
2660 -----------------------
2662 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2663 -- as static by the analyzer. The reason we did it that early is to allow
2664 -- the possibility of turning off the Is_Static_Expression flag after
2665 -- analysis, but before resolution, when integer literals are generated
2666 -- in the expander that do not correspond to static expressions.
2668 procedure Eval_Real_Literal (N : Node_Id) is
2669 PK : constant Node_Kind := Nkind (Parent (N));
2672 -- If the literal appears in a non-expression context and not as part of
2673 -- a number declaration, then it is appearing in a non-static context,
2676 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
2677 Check_Non_Static_Context (N);
2679 end Eval_Real_Literal;
2681 ------------------------
2682 -- Eval_Relational_Op --
2683 ------------------------
2685 -- Relational operations are static functions, so the result is static if
2686 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
2687 -- the result is never static, even if the operands are.
2689 procedure Eval_Relational_Op (N : Node_Id) is
2690 Left : constant Node_Id := Left_Opnd (N);
2691 Right : constant Node_Id := Right_Opnd (N);
2692 Typ : constant Entity_Id := Etype (Left);
2693 Otype : Entity_Id := Empty;
2699 -- One special case to deal with first. If we can tell that the result
2700 -- will be false because the lengths of one or more index subtypes are
2701 -- compile time known and different, then we can replace the entire
2702 -- result by False. We only do this for one dimensional arrays, because
2703 -- the case of multi-dimensional arrays is rare and too much trouble! If
2704 -- one of the operands is an illegal aggregate, its type might still be
2705 -- an arbitrary composite type, so nothing to do.
2707 if Is_Array_Type (Typ)
2708 and then Typ /= Any_Composite
2709 and then Number_Dimensions (Typ) = 1
2710 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
2712 if Raises_Constraint_Error (Left)
2713 or else Raises_Constraint_Error (Right)
2718 -- OK, we have the case where we may be able to do this fold
2720 Length_Mismatch : declare
2721 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
2722 -- If Op is an expression for a constrained array with a known at
2723 -- compile time length, then Len is set to this (non-negative
2724 -- length). Otherwise Len is set to minus 1.
2726 -----------------------
2727 -- Get_Static_Length --
2728 -----------------------
2730 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2734 -- First easy case string literal
2736 if Nkind (Op) = N_String_Literal then
2737 Len := UI_From_Int (String_Length (Strval (Op)));
2741 -- Second easy case, not constrained subtype, so no length
2743 if not Is_Constrained (Etype (Op)) then
2744 Len := Uint_Minus_1;
2750 T := Etype (First_Index (Etype (Op)));
2752 -- The simple case, both bounds are known at compile time
2754 if Is_Discrete_Type (T)
2756 Compile_Time_Known_Value (Type_Low_Bound (T))
2758 Compile_Time_Known_Value (Type_High_Bound (T))
2760 Len := UI_Max (Uint_0,
2761 Expr_Value (Type_High_Bound (T)) -
2762 Expr_Value (Type_Low_Bound (T)) + 1);
2766 -- A more complex case, where the bounds are of the form
2767 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2768 -- either A'First or A'Last (with A an entity name), or X is an
2769 -- entity name, and the two X's are the same and K1 and K2 are
2770 -- known at compile time, in this case, the length can also be
2771 -- computed at compile time, even though the bounds are not
2772 -- known. A common case of this is e.g. (X'First .. X'First+5).
2774 Extract_Length : declare
2775 procedure Decompose_Expr
2777 Ent : out Entity_Id;
2778 Kind : out Character;
2780 -- Given an expression, see if is of the form above,
2781 -- X [+/- K]. If so Ent is set to the entity in X,
2782 -- Kind is 'F','L','E' for 'First/'Last/simple entity,
2783 -- and Cons is the value of K. If the expression is
2784 -- not of the required form, Ent is set to Empty.
2786 --------------------
2787 -- Decompose_Expr --
2788 --------------------
2790 procedure Decompose_Expr
2792 Ent : out Entity_Id;
2793 Kind : out Character;
2799 if Nkind (Expr) = N_Op_Add
2800 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2802 Exp := Left_Opnd (Expr);
2803 Cons := Expr_Value (Right_Opnd (Expr));
2805 elsif Nkind (Expr) = N_Op_Subtract
2806 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2808 Exp := Left_Opnd (Expr);
2809 Cons := -Expr_Value (Right_Opnd (Expr));
2811 -- If the bound is a constant created to remove side
2812 -- effects, recover original expression to see if it has
2813 -- one of the recognizable forms.
2815 elsif Nkind (Expr) = N_Identifier
2816 and then not Comes_From_Source (Entity (Expr))
2817 and then Ekind (Entity (Expr)) = E_Constant
2819 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
2821 Exp := Expression (Parent (Entity (Expr)));
2822 Decompose_Expr (Exp, Ent, Kind, Cons);
2824 -- If original expression includes an entity, create a
2825 -- reference to it for use below.
2827 if Present (Ent) then
2828 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
2836 -- At this stage Exp is set to the potential X
2838 if Nkind (Exp) = N_Attribute_Reference then
2839 if Attribute_Name (Exp) = Name_First then
2842 elsif Attribute_Name (Exp) = Name_Last then
2850 Exp := Prefix (Exp);
2856 if Is_Entity_Name (Exp)
2857 and then Present (Entity (Exp))
2859 Ent := Entity (Exp);
2867 Ent1, Ent2 : Entity_Id;
2868 Kind1, Kind2 : Character;
2869 Cons1, Cons2 : Uint;
2871 -- Start of processing for Extract_Length
2875 (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
2877 (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
2880 and then Kind1 = Kind2
2881 and then Ent1 = Ent2
2883 Len := Cons2 - Cons1 + 1;
2885 Len := Uint_Minus_1;
2888 end Get_Static_Length;
2895 -- Start of processing for Length_Mismatch
2898 Get_Static_Length (Left, Len_L);
2899 Get_Static_Length (Right, Len_R);
2901 if Len_L /= Uint_Minus_1
2902 and then Len_R /= Uint_Minus_1
2903 and then Len_L /= Len_R
2905 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2906 Warn_On_Known_Condition (N);
2909 end Length_Mismatch;
2912 -- Test for expression being foldable
2914 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2916 -- Only comparisons of scalars can give static results. In particular,
2917 -- comparisons of strings never yield a static result, even if both
2918 -- operands are static strings.
2920 if not Is_Scalar_Type (Typ) then
2922 Set_Is_Static_Expression (N, False);
2925 -- For operators on universal numeric types called as functions with
2926 -- an explicit scope, determine appropriate specific numeric type, and
2927 -- diagnose possible ambiguity.
2929 if Is_Universal_Numeric_Type (Etype (Left))
2931 Is_Universal_Numeric_Type (Etype (Right))
2933 Otype := Find_Universal_Operator_Type (N);
2936 -- For static real type expressions, we cannot use Compile_Time_Compare
2937 -- since it worries about run-time results which are not exact.
2939 if Stat and then Is_Real_Type (Typ) then
2941 Left_Real : constant Ureal := Expr_Value_R (Left);
2942 Right_Real : constant Ureal := Expr_Value_R (Right);
2946 when N_Op_Eq => Result := (Left_Real = Right_Real);
2947 when N_Op_Ne => Result := (Left_Real /= Right_Real);
2948 when N_Op_Lt => Result := (Left_Real < Right_Real);
2949 when N_Op_Le => Result := (Left_Real <= Right_Real);
2950 when N_Op_Gt => Result := (Left_Real > Right_Real);
2951 when N_Op_Ge => Result := (Left_Real >= Right_Real);
2954 raise Program_Error;
2957 Fold_Uint (N, Test (Result), True);
2960 -- For all other cases, we use Compile_Time_Compare to do the compare
2964 CR : constant Compare_Result :=
2965 Compile_Time_Compare (Left, Right, Assume_Valid => False);
2968 if CR = Unknown then
2976 elsif CR = NE or else CR = GT or else CR = LT then
2983 if CR = NE or else CR = GT or else CR = LT then
2994 elsif CR = EQ or else CR = GT or else CR = GE then
3001 if CR = LT or else CR = EQ or else CR = LE then
3012 elsif CR = EQ or else CR = LT or else CR = LE then
3019 if CR = GT or else CR = EQ or else CR = GE then
3028 raise Program_Error;
3032 Fold_Uint (N, Test (Result), Stat);
3035 -- For the case of a folded relational operator on a specific numeric
3036 -- type, freeze operand type now.
3038 if Present (Otype) then
3039 Freeze_Before (N, Otype);
3042 Warn_On_Known_Condition (N);
3043 end Eval_Relational_Op;
3049 -- Shift operations are intrinsic operations that can never be static, so
3050 -- the only processing required is to perform the required check for a non
3051 -- static context for the two operands.
3053 -- Actually we could do some compile time evaluation here some time ???
3055 procedure Eval_Shift (N : Node_Id) is
3057 Check_Non_Static_Context (Left_Opnd (N));
3058 Check_Non_Static_Context (Right_Opnd (N));
3061 ------------------------
3062 -- Eval_Short_Circuit --
3063 ------------------------
3065 -- A short circuit operation is potentially static if both operands are
3066 -- potentially static (RM 4.9 (13)).
3068 procedure Eval_Short_Circuit (N : Node_Id) is
3069 Kind : constant Node_Kind := Nkind (N);
3070 Left : constant Node_Id := Left_Opnd (N);
3071 Right : constant Node_Id := Right_Opnd (N);
3074 Rstat : constant Boolean :=
3075 Is_Static_Expression (Left)
3077 Is_Static_Expression (Right);
3080 -- Short circuit operations are never static in Ada 83
3082 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3083 Check_Non_Static_Context (Left);
3084 Check_Non_Static_Context (Right);
3088 -- Now look at the operands, we can't quite use the normal call to
3089 -- Test_Expression_Is_Foldable here because short circuit operations
3090 -- are a special case, they can still be foldable, even if the right
3091 -- operand raises constraint error.
3093 -- If either operand is Any_Type, just propagate to result and do not
3094 -- try to fold, this prevents cascaded errors.
3096 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3097 Set_Etype (N, Any_Type);
3100 -- If left operand raises constraint error, then replace node N with
3101 -- the raise constraint error node, and we are obviously not foldable.
3102 -- Is_Static_Expression is set from the two operands in the normal way,
3103 -- and we check the right operand if it is in a non-static context.
3105 elsif Raises_Constraint_Error (Left) then
3107 Check_Non_Static_Context (Right);
3110 Rewrite_In_Raise_CE (N, Left);
3111 Set_Is_Static_Expression (N, Rstat);
3114 -- If the result is not static, then we won't in any case fold
3116 elsif not Rstat then
3117 Check_Non_Static_Context (Left);
3118 Check_Non_Static_Context (Right);
3122 -- Here the result is static, note that, unlike the normal processing
3123 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3124 -- the right operand raises constraint error, that's because it is not
3125 -- significant if the left operand is decisive.
3127 Set_Is_Static_Expression (N);
3129 -- It does not matter if the right operand raises constraint error if
3130 -- it will not be evaluated. So deal specially with the cases where
3131 -- the right operand is not evaluated. Note that we will fold these
3132 -- cases even if the right operand is non-static, which is fine, but
3133 -- of course in these cases the result is not potentially static.
3135 Left_Int := Expr_Value (Left);
3137 if (Kind = N_And_Then and then Is_False (Left_Int))
3139 (Kind = N_Or_Else and then Is_True (Left_Int))
3141 Fold_Uint (N, Left_Int, Rstat);
3145 -- If first operand not decisive, then it does matter if the right
3146 -- operand raises constraint error, since it will be evaluated, so
3147 -- we simply replace the node with the right operand. Note that this
3148 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3149 -- (both are set to True in Right).
3151 if Raises_Constraint_Error (Right) then
3152 Rewrite_In_Raise_CE (N, Right);
3153 Check_Non_Static_Context (Left);
3157 -- Otherwise the result depends on the right operand
3159 Fold_Uint (N, Expr_Value (Right), Rstat);
3161 end Eval_Short_Circuit;
3167 -- Slices can never be static, so the only processing required is to check
3168 -- for non-static context if an explicit range is given.
3170 procedure Eval_Slice (N : Node_Id) is
3171 Drange : constant Node_Id := Discrete_Range (N);
3173 if Nkind (Drange) = N_Range then
3174 Check_Non_Static_Context (Low_Bound (Drange));
3175 Check_Non_Static_Context (High_Bound (Drange));
3178 -- A slice of the form A (subtype), when the subtype is the index of
3179 -- the type of A, is redundant, the slice can be replaced with A, and
3180 -- this is worth a warning.
3182 if Is_Entity_Name (Prefix (N)) then
3184 E : constant Entity_Id := Entity (Prefix (N));
3185 T : constant Entity_Id := Etype (E);
3187 if Ekind (E) = E_Constant
3188 and then Is_Array_Type (T)
3189 and then Is_Entity_Name (Drange)
3191 if Is_Entity_Name (Original_Node (First_Index (T)))
3192 and then Entity (Original_Node (First_Index (T)))
3195 if Warn_On_Redundant_Constructs then
3196 Error_Msg_N ("redundant slice denotes whole array?", N);
3199 -- The following might be a useful optimization????
3201 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3208 -------------------------
3209 -- Eval_String_Literal --
3210 -------------------------
3212 procedure Eval_String_Literal (N : Node_Id) is
3213 Typ : constant Entity_Id := Etype (N);
3214 Bas : constant Entity_Id := Base_Type (Typ);
3220 -- Nothing to do if error type (handles cases like default expressions
3221 -- or generics where we have not yet fully resolved the type).
3223 if Bas = Any_Type or else Bas = Any_String then
3227 -- String literals are static if the subtype is static (RM 4.9(2)), so
3228 -- reset the static expression flag (it was set unconditionally in
3229 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3230 -- the subtype is static by looking at the lower bound.
3232 if Ekind (Typ) = E_String_Literal_Subtype then
3233 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3234 Set_Is_Static_Expression (N, False);
3238 -- Here if Etype of string literal is normal Etype (not yet possible,
3239 -- but may be possible in future).
3241 elsif not Is_OK_Static_Expression
3242 (Type_Low_Bound (Etype (First_Index (Typ))))
3244 Set_Is_Static_Expression (N, False);
3248 -- If original node was a type conversion, then result if non-static
3250 if Nkind (Original_Node (N)) = N_Type_Conversion then
3251 Set_Is_Static_Expression (N, False);
3255 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3256 -- if its bounds are outside the index base type and this index type is
3257 -- static. This can happen in only two ways. Either the string literal
3258 -- is too long, or it is null, and the lower bound is type'First. In
3259 -- either case it is the upper bound that is out of range of the index
3262 if Ada_Version >= Ada_95 then
3263 if Root_Type (Bas) = Standard_String
3265 Root_Type (Bas) = Standard_Wide_String
3267 Xtp := Standard_Positive;
3269 Xtp := Etype (First_Index (Bas));
3272 if Ekind (Typ) = E_String_Literal_Subtype then
3273 Lo := String_Literal_Low_Bound (Typ);
3275 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3278 Len := String_Length (Strval (N));
3280 if UI_From_Int (Len) > String_Type_Len (Bas) then
3281 Apply_Compile_Time_Constraint_Error
3282 (N, "string literal too long for}", CE_Length_Check_Failed,
3284 Typ => First_Subtype (Bas));
3287 and then not Is_Generic_Type (Xtp)
3289 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3291 Apply_Compile_Time_Constraint_Error
3292 (N, "null string literal not allowed for}",
3293 CE_Length_Check_Failed,
3295 Typ => First_Subtype (Bas));
3298 end Eval_String_Literal;
3300 --------------------------
3301 -- Eval_Type_Conversion --
3302 --------------------------
3304 -- A type conversion is potentially static if its subtype mark is for a
3305 -- static scalar subtype, and its operand expression is potentially static
3308 procedure Eval_Type_Conversion (N : Node_Id) is
3309 Operand : constant Node_Id := Expression (N);
3310 Source_Type : constant Entity_Id := Etype (Operand);
3311 Target_Type : constant Entity_Id := Etype (N);
3316 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3317 -- Returns true if type T is an integer type, or if it is a fixed-point
3318 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3319 -- on the conversion node).
3321 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3322 -- Returns true if type T is a floating-point type, or if it is a
3323 -- fixed-point type that is not to be treated as an integer (i.e. the
3324 -- flag Conversion_OK is not set on the conversion node).
3326 ------------------------------
3327 -- To_Be_Treated_As_Integer --
3328 ------------------------------
3330 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3334 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3335 end To_Be_Treated_As_Integer;
3337 ---------------------------
3338 -- To_Be_Treated_As_Real --
3339 ---------------------------
3341 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3344 Is_Floating_Point_Type (T)
3345 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3346 end To_Be_Treated_As_Real;
3348 -- Start of processing for Eval_Type_Conversion
3351 -- Cannot fold if target type is non-static or if semantic error
3353 if not Is_Static_Subtype (Target_Type) then
3354 Check_Non_Static_Context (Operand);
3357 elsif Error_Posted (N) then
3361 -- If not foldable we are done
3363 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3368 -- Don't try fold if target type has constraint error bounds
3370 elsif not Is_OK_Static_Subtype (Target_Type) then
3371 Set_Raises_Constraint_Error (N);
3375 -- Remaining processing depends on operand types. Note that in the
3376 -- following type test, fixed-point counts as real unless the flag
3377 -- Conversion_OK is set, in which case it counts as integer.
3379 -- Fold conversion, case of string type. The result is not static
3381 if Is_String_Type (Target_Type) then
3382 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3386 -- Fold conversion, case of integer target type
3388 elsif To_Be_Treated_As_Integer (Target_Type) then
3393 -- Integer to integer conversion
3395 if To_Be_Treated_As_Integer (Source_Type) then
3396 Result := Expr_Value (Operand);
3398 -- Real to integer conversion
3401 Result := UR_To_Uint (Expr_Value_R (Operand));
3404 -- If fixed-point type (Conversion_OK must be set), then the
3405 -- result is logically an integer, but we must replace the
3406 -- conversion with the corresponding real literal, since the
3407 -- type from a semantic point of view is still fixed-point.
3409 if Is_Fixed_Point_Type (Target_Type) then
3411 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3413 -- Otherwise result is integer literal
3416 Fold_Uint (N, Result, Stat);
3420 -- Fold conversion, case of real target type
3422 elsif To_Be_Treated_As_Real (Target_Type) then
3427 if To_Be_Treated_As_Real (Source_Type) then
3428 Result := Expr_Value_R (Operand);
3430 Result := UR_From_Uint (Expr_Value (Operand));
3433 Fold_Ureal (N, Result, Stat);
3436 -- Enumeration types
3439 Fold_Uint (N, Expr_Value (Operand), Stat);
3442 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3446 end Eval_Type_Conversion;
3452 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3453 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3455 procedure Eval_Unary_Op (N : Node_Id) is
3456 Right : constant Node_Id := Right_Opnd (N);
3457 Otype : Entity_Id := Empty;
3462 -- If not foldable we are done
3464 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3470 if Etype (Right) = Universal_Integer
3472 Etype (Right) = Universal_Real
3474 Otype := Find_Universal_Operator_Type (N);
3477 -- Fold for integer case
3479 if Is_Integer_Type (Etype (N)) then
3481 Rint : constant Uint := Expr_Value (Right);
3485 -- In the case of modular unary plus and abs there is no need
3486 -- to adjust the result of the operation since if the original
3487 -- operand was in bounds the result will be in the bounds of the
3488 -- modular type. However, in the case of modular unary minus the
3489 -- result may go out of the bounds of the modular type and needs
3492 if Nkind (N) = N_Op_Plus then
3495 elsif Nkind (N) = N_Op_Minus then
3496 if Is_Modular_Integer_Type (Etype (N)) then
3497 Result := (-Rint) mod Modulus (Etype (N));
3503 pragma Assert (Nkind (N) = N_Op_Abs);
3507 Fold_Uint (N, Result, Stat);
3510 -- Fold for real case
3512 elsif Is_Real_Type (Etype (N)) then
3514 Rreal : constant Ureal := Expr_Value_R (Right);
3518 if Nkind (N) = N_Op_Plus then
3521 elsif Nkind (N) = N_Op_Minus then
3522 Result := UR_Negate (Rreal);
3525 pragma Assert (Nkind (N) = N_Op_Abs);
3526 Result := abs Rreal;
3529 Fold_Ureal (N, Result, Stat);
3533 -- If the operator was resolved to a specific type, make sure that type
3534 -- is frozen even if the expression is folded into a literal (which has
3535 -- a universal type).
3537 if Present (Otype) then
3538 Freeze_Before (N, Otype);
3542 -------------------------------
3543 -- Eval_Unchecked_Conversion --
3544 -------------------------------
3546 -- Unchecked conversions can never be static, so the only required
3547 -- processing is to check for a non-static context for the operand.
3549 procedure Eval_Unchecked_Conversion (N : Node_Id) is
3551 Check_Non_Static_Context (Expression (N));
3552 end Eval_Unchecked_Conversion;
3554 --------------------
3555 -- Expr_Rep_Value --
3556 --------------------
3558 function Expr_Rep_Value (N : Node_Id) return Uint is
3559 Kind : constant Node_Kind := Nkind (N);
3563 if Is_Entity_Name (N) then
3566 -- An enumeration literal that was either in the source or created
3567 -- as a result of static evaluation.
3569 if Ekind (Ent) = E_Enumeration_Literal then
3570 return Enumeration_Rep (Ent);
3572 -- A user defined static constant
3575 pragma Assert (Ekind (Ent) = E_Constant);
3576 return Expr_Rep_Value (Constant_Value (Ent));
3579 -- An integer literal that was either in the source or created as a
3580 -- result of static evaluation.
3582 elsif Kind = N_Integer_Literal then
3585 -- A real literal for a fixed-point type. This must be the fixed-point
3586 -- case, either the literal is of a fixed-point type, or it is a bound
3587 -- of a fixed-point type, with type universal real. In either case we
3588 -- obtain the desired value from Corresponding_Integer_Value.
3590 elsif Kind = N_Real_Literal then
3591 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3592 return Corresponding_Integer_Value (N);
3594 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3596 elsif Kind = N_Attribute_Reference
3597 and then Attribute_Name (N) = Name_Null_Parameter
3601 -- Otherwise must be character literal
3604 pragma Assert (Kind = N_Character_Literal);
3607 -- Since Character literals of type Standard.Character don't have any
3608 -- defining character literals built for them, they do not have their
3609 -- Entity set, so just use their Char code. Otherwise for user-
3610 -- defined character literals use their Pos value as usual which is
3611 -- the same as the Rep value.
3614 return Char_Literal_Value (N);
3616 return Enumeration_Rep (Ent);
3625 function Expr_Value (N : Node_Id) return Uint is
3626 Kind : constant Node_Kind := Nkind (N);
3627 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3632 -- If already in cache, then we know it's compile time known and we can
3633 -- return the value that was previously stored in the cache since
3634 -- compile time known values cannot change.
3636 if CV_Ent.N = N then
3640 -- Otherwise proceed to test value
3642 if Is_Entity_Name (N) then
3645 -- An enumeration literal that was either in the source or created as
3646 -- a result of static evaluation.
3648 if Ekind (Ent) = E_Enumeration_Literal then
3649 Val := Enumeration_Pos (Ent);
3651 -- A user defined static constant
3654 pragma Assert (Ekind (Ent) = E_Constant);
3655 Val := Expr_Value (Constant_Value (Ent));
3658 -- An integer literal that was either in the source or created as a
3659 -- result of static evaluation.
3661 elsif Kind = N_Integer_Literal then
3664 -- A real literal for a fixed-point type. This must be the fixed-point
3665 -- case, either the literal is of a fixed-point type, or it is a bound
3666 -- of a fixed-point type, with type universal real. In either case we
3667 -- obtain the desired value from Corresponding_Integer_Value.
3669 elsif Kind = N_Real_Literal then
3671 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3672 Val := Corresponding_Integer_Value (N);
3674 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3676 elsif Kind = N_Attribute_Reference
3677 and then Attribute_Name (N) = Name_Null_Parameter
3681 -- Otherwise must be character literal
3684 pragma Assert (Kind = N_Character_Literal);
3687 -- Since Character literals of type Standard.Character don't
3688 -- have any defining character literals built for them, they
3689 -- do not have their Entity set, so just use their Char
3690 -- code. Otherwise for user-defined character literals use
3691 -- their Pos value as usual.
3694 Val := Char_Literal_Value (N);
3696 Val := Enumeration_Pos (Ent);
3700 -- Come here with Val set to value to be returned, set cache
3711 function Expr_Value_E (N : Node_Id) return Entity_Id is
3712 Ent : constant Entity_Id := Entity (N);
3715 if Ekind (Ent) = E_Enumeration_Literal then
3718 pragma Assert (Ekind (Ent) = E_Constant);
3719 return Expr_Value_E (Constant_Value (Ent));
3727 function Expr_Value_R (N : Node_Id) return Ureal is
3728 Kind : constant Node_Kind := Nkind (N);
3733 if Kind = N_Real_Literal then
3736 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3738 pragma Assert (Ekind (Ent) = E_Constant);
3739 return Expr_Value_R (Constant_Value (Ent));
3741 elsif Kind = N_Integer_Literal then
3742 return UR_From_Uint (Expr_Value (N));
3744 -- Strange case of VAX literals, which are at this stage transformed
3745 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3746 -- Exp_Vfpt for further details.
3748 elsif Vax_Float (Etype (N))
3749 and then Nkind (N) = N_Unchecked_Type_Conversion
3751 Expr := Expression (N);
3753 if Nkind (Expr) = N_Function_Call
3754 and then Present (Parameter_Associations (Expr))
3756 Expr := First (Parameter_Associations (Expr));
3758 if Nkind (Expr) = N_Real_Literal then
3759 return Realval (Expr);
3763 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3765 elsif Kind = N_Attribute_Reference
3766 and then Attribute_Name (N) = Name_Null_Parameter
3771 -- If we fall through, we have a node that cannot be interpreted as a
3772 -- compile time constant. That is definitely an error.
3774 raise Program_Error;
3781 function Expr_Value_S (N : Node_Id) return Node_Id is
3783 if Nkind (N) = N_String_Literal then
3786 pragma Assert (Ekind (Entity (N)) = E_Constant);
3787 return Expr_Value_S (Constant_Value (Entity (N)));
3791 ----------------------------------
3792 -- Find_Universal_Operator_Type --
3793 ----------------------------------
3795 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
3796 PN : constant Node_Id := Parent (N);
3797 Call : constant Node_Id := Original_Node (N);
3798 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
3800 Is_Fix : constant Boolean :=
3801 Nkind (N) in N_Binary_Op
3802 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
3803 -- A mixed-mode operation in this context indicates the presence of
3804 -- fixed-point type in the designated package.
3806 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
3807 -- Case where N is a relational (or membership) operator (else it is an
3810 In_Membership : constant Boolean :=
3811 Nkind (PN) in N_Membership_Test
3813 Nkind (Right_Opnd (PN)) = N_Range
3815 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
3817 Is_Universal_Numeric_Type
3818 (Etype (Low_Bound (Right_Opnd (PN))))
3820 Is_Universal_Numeric_Type
3821 (Etype (High_Bound (Right_Opnd (PN))));
3822 -- Case where N is part of a membership test with a universal range
3826 Typ1 : Entity_Id := Empty;
3829 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
3830 -- Check whether one operand is a mixed-mode operation that requires the
3831 -- presence of a fixed-point type. Given that all operands are universal
3832 -- and have been constant-folded, retrieve the original function call.
3834 ---------------------------
3835 -- Is_Mixed_Mode_Operand --
3836 ---------------------------
3838 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
3839 Onod : constant Node_Id := Original_Node (Op);
3841 return Nkind (Onod) = N_Function_Call
3842 and then Present (Next_Actual (First_Actual (Onod)))
3843 and then Etype (First_Actual (Onod)) /=
3844 Etype (Next_Actual (First_Actual (Onod)));
3845 end Is_Mixed_Mode_Operand;
3847 -- Start of processing for Find_Universal_Operator_Type
3850 if Nkind (Call) /= N_Function_Call
3851 or else Nkind (Name (Call)) /= N_Expanded_Name
3855 -- There are several cases where the context does not imply the type of
3857 -- - the universal expression appears in a type conversion;
3858 -- - the expression is a relational operator applied to universal
3860 -- - the expression is a membership test with a universal operand
3861 -- and a range with universal bounds.
3863 elsif Nkind (Parent (N)) = N_Type_Conversion
3864 or else Is_Relational
3865 or else In_Membership
3867 Pack := Entity (Prefix (Name (Call)));
3869 -- If the prefix is a package declared elsewhere, iterate over its
3870 -- visible entities, otherwise iterate over all declarations in the
3871 -- designated scope.
3873 if Ekind (Pack) = E_Package
3874 and then not In_Open_Scopes (Pack)
3876 Priv_E := First_Private_Entity (Pack);
3882 E := First_Entity (Pack);
3883 while Present (E) and then E /= Priv_E loop
3884 if Is_Numeric_Type (E)
3885 and then Nkind (Parent (E)) /= N_Subtype_Declaration
3886 and then Comes_From_Source (E)
3887 and then Is_Integer_Type (E) = Is_Int
3889 (Nkind (N) in N_Unary_Op
3890 or else Is_Relational
3891 or else Is_Fixed_Point_Type (E) = Is_Fix)
3896 -- Before emitting an error, check for the presence of a
3897 -- mixed-mode operation that specifies a fixed point type.
3901 (Is_Mixed_Mode_Operand (Left_Opnd (N))
3902 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
3903 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
3906 if Is_Fixed_Point_Type (E) then
3911 -- More than one type of the proper class declared in P
3913 Error_Msg_N ("ambiguous operation", N);
3914 Error_Msg_Sloc := Sloc (Typ1);
3915 Error_Msg_N ("\possible interpretation (inherited)#", N);
3916 Error_Msg_Sloc := Sloc (E);
3917 Error_Msg_N ("\possible interpretation (inherited)#", N);
3927 end Find_Universal_Operator_Type;
3929 --------------------------
3930 -- Flag_Non_Static_Expr --
3931 --------------------------
3933 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
3935 if Error_Posted (Expr) and then not All_Errors_Mode then
3938 Error_Msg_F (Msg, Expr);
3939 Why_Not_Static (Expr);
3941 end Flag_Non_Static_Expr;
3947 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
3948 Loc : constant Source_Ptr := Sloc (N);
3949 Typ : constant Entity_Id := Etype (N);
3952 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
3954 -- We now have the literal with the right value, both the actual type
3955 -- and the expected type of this literal are taken from the expression
3956 -- that was evaluated.
3959 Set_Is_Static_Expression (N, Static);
3968 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
3969 Loc : constant Source_Ptr := Sloc (N);
3970 Typ : Entity_Id := Etype (N);
3974 -- If we are folding a named number, retain the entity in the literal,
3977 if Is_Entity_Name (N)
3978 and then Ekind (Entity (N)) = E_Named_Integer
3985 if Is_Private_Type (Typ) then
3986 Typ := Full_View (Typ);
3989 -- For a result of type integer, substitute an N_Integer_Literal node
3990 -- for the result of the compile time evaluation of the expression.
3991 -- For ASIS use, set a link to the original named number when not in
3992 -- a generic context.
3994 if Is_Integer_Type (Typ) then
3995 Rewrite (N, Make_Integer_Literal (Loc, Val));
3997 Set_Original_Entity (N, Ent);
3999 -- Otherwise we have an enumeration type, and we substitute either
4000 -- an N_Identifier or N_Character_Literal to represent the enumeration
4001 -- literal corresponding to the given value, which must always be in
4002 -- range, because appropriate tests have already been made for this.
4004 else pragma Assert (Is_Enumeration_Type (Typ));
4005 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4008 -- We now have the literal with the right value, both the actual type
4009 -- and the expected type of this literal are taken from the expression
4010 -- that was evaluated.
4013 Set_Is_Static_Expression (N, Static);
4022 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4023 Loc : constant Source_Ptr := Sloc (N);
4024 Typ : constant Entity_Id := Etype (N);
4028 -- If we are folding a named number, retain the entity in the literal,
4031 if Is_Entity_Name (N)
4032 and then Ekind (Entity (N)) = E_Named_Real
4039 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4041 -- Set link to original named number, for ASIS use
4043 Set_Original_Entity (N, Ent);
4045 -- Both the actual and expected type comes from the original expression
4048 Set_Is_Static_Expression (N, Static);
4057 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4061 for J in 0 .. B'Last loop
4067 if Non_Binary_Modulus (T) then
4068 V := V mod Modulus (T);
4074 --------------------
4075 -- Get_String_Val --
4076 --------------------
4078 function Get_String_Val (N : Node_Id) return Node_Id is
4080 if Nkind (N) = N_String_Literal then
4083 elsif Nkind (N) = N_Character_Literal then
4087 pragma Assert (Is_Entity_Name (N));
4088 return Get_String_Val (Constant_Value (Entity (N)));
4096 procedure Initialize is
4098 CV_Cache := (others => (Node_High_Bound, Uint_0));
4101 --------------------
4102 -- In_Subrange_Of --
4103 --------------------
4105 function In_Subrange_Of
4108 Fixed_Int : Boolean := False) return Boolean
4117 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4120 -- Never in range if both types are not scalar. Don't know if this can
4121 -- actually happen, but just in case.
4123 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
4126 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4127 -- definitely not compatible with T2.
4129 elsif Is_Floating_Point_Type (T1)
4130 and then Has_Infinities (T1)
4131 and then Is_Floating_Point_Type (T2)
4132 and then not Has_Infinities (T2)
4137 L1 := Type_Low_Bound (T1);
4138 H1 := Type_High_Bound (T1);
4140 L2 := Type_Low_Bound (T2);
4141 H2 := Type_High_Bound (T2);
4143 -- Check bounds to see if comparison possible at compile time
4145 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4147 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4152 -- If bounds not comparable at compile time, then the bounds of T2
4153 -- must be compile time known or we cannot answer the query.
4155 if not Compile_Time_Known_Value (L2)
4156 or else not Compile_Time_Known_Value (H2)
4161 -- If the bounds of T1 are know at compile time then use these
4162 -- ones, otherwise use the bounds of the base type (which are of
4163 -- course always static).
4165 if not Compile_Time_Known_Value (L1) then
4166 L1 := Type_Low_Bound (Base_Type (T1));
4169 if not Compile_Time_Known_Value (H1) then
4170 H1 := Type_High_Bound (Base_Type (T1));
4173 -- Fixed point types should be considered as such only if
4174 -- flag Fixed_Int is set to False.
4176 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4177 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4178 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4181 Expr_Value_R (L2) <= Expr_Value_R (L1)
4183 Expr_Value_R (H2) >= Expr_Value_R (H1);
4187 Expr_Value (L2) <= Expr_Value (L1)
4189 Expr_Value (H2) >= Expr_Value (H1);
4194 -- If any exception occurs, it means that we have some bug in the compiler
4195 -- possibly triggered by a previous error, or by some unforeseen peculiar
4196 -- occurrence. However, this is only an optimization attempt, so there is
4197 -- really no point in crashing the compiler. Instead we just decide, too
4198 -- bad, we can't figure out the answer in this case after all.
4203 -- Debug flag K disables this behavior (useful for debugging)
4205 if Debug_Flag_K then
4216 function Is_In_Range
4219 Assume_Valid : Boolean := False;
4220 Fixed_Int : Boolean := False;
4221 Int_Real : Boolean := False) return Boolean
4224 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
4232 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4233 Typ : constant Entity_Id := Etype (Lo);
4236 if not Compile_Time_Known_Value (Lo)
4237 or else not Compile_Time_Known_Value (Hi)
4242 if Is_Discrete_Type (Typ) then
4243 return Expr_Value (Lo) > Expr_Value (Hi);
4246 pragma Assert (Is_Real_Type (Typ));
4247 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4251 -----------------------------
4252 -- Is_OK_Static_Expression --
4253 -----------------------------
4255 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4257 return Is_Static_Expression (N)
4258 and then not Raises_Constraint_Error (N);
4259 end Is_OK_Static_Expression;
4261 ------------------------
4262 -- Is_OK_Static_Range --
4263 ------------------------
4265 -- A static range is a range whose bounds are static expressions, or a
4266 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4267 -- We have already converted range attribute references, so we get the
4268 -- "or" part of this rule without needing a special test.
4270 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4272 return Is_OK_Static_Expression (Low_Bound (N))
4273 and then Is_OK_Static_Expression (High_Bound (N));
4274 end Is_OK_Static_Range;
4276 --------------------------
4277 -- Is_OK_Static_Subtype --
4278 --------------------------
4280 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4281 -- neither bound raises constraint error when evaluated.
4283 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4284 Base_T : constant Entity_Id := Base_Type (Typ);
4285 Anc_Subt : Entity_Id;
4288 -- First a quick check on the non static subtype flag. As described
4289 -- in further detail in Einfo, this flag is not decisive in all cases,
4290 -- but if it is set, then the subtype is definitely non-static.
4292 if Is_Non_Static_Subtype (Typ) then
4296 Anc_Subt := Ancestor_Subtype (Typ);
4298 if Anc_Subt = Empty then
4302 if Is_Generic_Type (Root_Type (Base_T))
4303 or else Is_Generic_Actual_Type (Base_T)
4309 elsif Is_String_Type (Typ) then
4311 Ekind (Typ) = E_String_Literal_Subtype
4313 (Is_OK_Static_Subtype (Component_Type (Typ))
4314 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4318 elsif Is_Scalar_Type (Typ) then
4319 if Base_T = Typ then
4323 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4324 -- Get_Type_{Low,High}_Bound.
4326 return Is_OK_Static_Subtype (Anc_Subt)
4327 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4328 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4331 -- Types other than string and scalar types are never static
4336 end Is_OK_Static_Subtype;
4338 ---------------------
4339 -- Is_Out_Of_Range --
4340 ---------------------
4342 function Is_Out_Of_Range
4345 Assume_Valid : Boolean := False;
4346 Fixed_Int : Boolean := False;
4347 Int_Real : Boolean := False) return Boolean
4350 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
4352 end Is_Out_Of_Range;
4354 ---------------------
4355 -- Is_Static_Range --
4356 ---------------------
4358 -- A static range is a range whose bounds are static expressions, or a
4359 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4360 -- We have already converted range attribute references, so we get the
4361 -- "or" part of this rule without needing a special test.
4363 function Is_Static_Range (N : Node_Id) return Boolean is
4365 return Is_Static_Expression (Low_Bound (N))
4366 and then Is_Static_Expression (High_Bound (N));
4367 end Is_Static_Range;
4369 -----------------------
4370 -- Is_Static_Subtype --
4371 -----------------------
4373 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4375 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4376 Base_T : constant Entity_Id := Base_Type (Typ);
4377 Anc_Subt : Entity_Id;
4380 -- First a quick check on the non static subtype flag. As described
4381 -- in further detail in Einfo, this flag is not decisive in all cases,
4382 -- but if it is set, then the subtype is definitely non-static.
4384 if Is_Non_Static_Subtype (Typ) then
4388 Anc_Subt := Ancestor_Subtype (Typ);
4390 if Anc_Subt = Empty then
4394 if Is_Generic_Type (Root_Type (Base_T))
4395 or else Is_Generic_Actual_Type (Base_T)
4401 elsif Is_String_Type (Typ) then
4403 Ekind (Typ) = E_String_Literal_Subtype
4405 (Is_Static_Subtype (Component_Type (Typ))
4406 and then Is_Static_Subtype (Etype (First_Index (Typ))));
4410 elsif Is_Scalar_Type (Typ) then
4411 if Base_T = Typ then
4415 return Is_Static_Subtype (Anc_Subt)
4416 and then Is_Static_Expression (Type_Low_Bound (Typ))
4417 and then Is_Static_Expression (Type_High_Bound (Typ));
4420 -- Types other than string and scalar types are never static
4425 end Is_Static_Subtype;
4427 --------------------
4428 -- Not_Null_Range --
4429 --------------------
4431 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4432 Typ : constant Entity_Id := Etype (Lo);
4435 if not Compile_Time_Known_Value (Lo)
4436 or else not Compile_Time_Known_Value (Hi)
4441 if Is_Discrete_Type (Typ) then
4442 return Expr_Value (Lo) <= Expr_Value (Hi);
4445 pragma Assert (Is_Real_Type (Typ));
4447 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
4455 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
4457 -- We allow a maximum of 500,000 bits which seems a reasonable limit
4459 if Bits < 500_000 then
4463 Error_Msg_N ("static value too large, capacity exceeded", N);
4472 procedure Out_Of_Range (N : Node_Id) is
4474 -- If we have the static expression case, then this is an illegality
4475 -- in Ada 95 mode, except that in an instance, we never generate an
4476 -- error (if the error is legitimate, it was already diagnosed in the
4477 -- template). The expression to compute the length of a packed array is
4478 -- attached to the array type itself, and deserves a separate message.
4480 if Is_Static_Expression (N)
4481 and then not In_Instance
4482 and then not In_Inlined_Body
4483 and then Ada_Version >= Ada_95
4485 if Nkind (Parent (N)) = N_Defining_Identifier
4486 and then Is_Array_Type (Parent (N))
4487 and then Present (Packed_Array_Type (Parent (N)))
4488 and then Present (First_Rep_Item (Parent (N)))
4491 ("length of packed array must not exceed Integer''Last",
4492 First_Rep_Item (Parent (N)));
4493 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
4496 Apply_Compile_Time_Constraint_Error
4497 (N, "value not in range of}", CE_Range_Check_Failed);
4500 -- Here we generate a warning for the Ada 83 case, or when we are in an
4501 -- instance, or when we have a non-static expression case.
4504 Apply_Compile_Time_Constraint_Error
4505 (N, "value not in range of}?", CE_Range_Check_Failed);
4509 -------------------------
4510 -- Rewrite_In_Raise_CE --
4511 -------------------------
4513 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
4514 Typ : constant Entity_Id := Etype (N);
4517 -- If we want to raise CE in the condition of a N_Raise_CE node
4518 -- we may as well get rid of the condition.
4520 if Present (Parent (N))
4521 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
4523 Set_Condition (Parent (N), Empty);
4525 -- If the expression raising CE is a N_Raise_CE node, we can use that
4526 -- one. We just preserve the type of the context.
4528 elsif Nkind (Exp) = N_Raise_Constraint_Error then
4532 -- Else build an explcit N_Raise_CE
4536 Make_Raise_Constraint_Error (Sloc (Exp),
4537 Reason => CE_Range_Check_Failed));
4538 Set_Raises_Constraint_Error (N);
4541 end Rewrite_In_Raise_CE;
4543 ---------------------
4544 -- String_Type_Len --
4545 ---------------------
4547 function String_Type_Len (Stype : Entity_Id) return Uint is
4548 NT : constant Entity_Id := Etype (First_Index (Stype));
4552 if Is_OK_Static_Subtype (NT) then
4555 T := Base_Type (NT);
4558 return Expr_Value (Type_High_Bound (T)) -
4559 Expr_Value (Type_Low_Bound (T)) + 1;
4560 end String_Type_Len;
4562 ------------------------------------
4563 -- Subtypes_Statically_Compatible --
4564 ------------------------------------
4566 function Subtypes_Statically_Compatible
4568 T2 : Entity_Id) return Boolean
4573 if Is_Scalar_Type (T1) then
4575 -- Definitely compatible if we match
4577 if Subtypes_Statically_Match (T1, T2) then
4580 -- If either subtype is nonstatic then they're not compatible
4582 elsif not Is_Static_Subtype (T1)
4583 or else not Is_Static_Subtype (T2)
4587 -- If either type has constraint error bounds, then consider that
4588 -- they match to avoid junk cascaded errors here.
4590 elsif not Is_OK_Static_Subtype (T1)
4591 or else not Is_OK_Static_Subtype (T2)
4595 -- Base types must match, but we don't check that (should we???) but
4596 -- we do at least check that both types are real, or both types are
4599 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
4602 -- Here we check the bounds
4606 LB1 : constant Node_Id := Type_Low_Bound (T1);
4607 HB1 : constant Node_Id := Type_High_Bound (T1);
4608 LB2 : constant Node_Id := Type_Low_Bound (T2);
4609 HB2 : constant Node_Id := Type_High_Bound (T2);
4612 if Is_Real_Type (T1) then
4614 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4616 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4618 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4622 (Expr_Value (LB1) > Expr_Value (HB1))
4624 (Expr_Value (LB2) <= Expr_Value (LB1)
4626 Expr_Value (HB1) <= Expr_Value (HB2));
4633 elsif Is_Access_Type (T1) then
4634 return (not Is_Constrained (T2)
4635 or else (Subtypes_Statically_Match
4636 (Designated_Type (T1), Designated_Type (T2))))
4637 and then not (Can_Never_Be_Null (T2)
4638 and then not Can_Never_Be_Null (T1));
4643 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4644 or else Subtypes_Statically_Match (T1, T2);
4646 end Subtypes_Statically_Compatible;
4648 -------------------------------
4649 -- Subtypes_Statically_Match --
4650 -------------------------------
4652 -- Subtypes statically match if they have statically matching constraints
4653 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4654 -- they are the same identical constraint, or if they are static and the
4655 -- values match (RM 4.9.1(1)).
4657 function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
4659 -- A type always statically matches itself
4666 elsif Is_Scalar_Type (T1) then
4668 -- Base types must be the same
4670 if Base_Type (T1) /= Base_Type (T2) then
4674 -- A constrained numeric subtype never matches an unconstrained
4675 -- subtype, i.e. both types must be constrained or unconstrained.
4677 -- To understand the requirement for this test, see RM 4.9.1(1).
4678 -- As is made clear in RM 3.5.4(11), type Integer, for example is
4679 -- a constrained subtype with constraint bounds matching the bounds
4680 -- of its corresponding unconstrained base type. In this situation,
4681 -- Integer and Integer'Base do not statically match, even though
4682 -- they have the same bounds.
4684 -- We only apply this test to types in Standard and types that appear
4685 -- in user programs. That way, we do not have to be too careful about
4686 -- setting Is_Constrained right for Itypes.
4688 if Is_Numeric_Type (T1)
4689 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4690 and then (Scope (T1) = Standard_Standard
4691 or else Comes_From_Source (T1))
4692 and then (Scope (T2) = Standard_Standard
4693 or else Comes_From_Source (T2))
4697 -- A generic scalar type does not statically match its base type
4698 -- (AI-311). In this case we make sure that the formals, which are
4699 -- first subtypes of their bases, are constrained.
4701 elsif Is_Generic_Type (T1)
4702 and then Is_Generic_Type (T2)
4703 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4708 -- If there was an error in either range, then just assume the types
4709 -- statically match to avoid further junk errors.
4711 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
4712 or else Error_Posted (Scalar_Range (T1))
4713 or else Error_Posted (Scalar_Range (T2))
4718 -- Otherwise both types have bound that can be compared
4721 LB1 : constant Node_Id := Type_Low_Bound (T1);
4722 HB1 : constant Node_Id := Type_High_Bound (T1);
4723 LB2 : constant Node_Id := Type_Low_Bound (T2);
4724 HB2 : constant Node_Id := Type_High_Bound (T2);
4727 -- If the bounds are the same tree node, then match
4729 if LB1 = LB2 and then HB1 = HB2 then
4732 -- Otherwise bounds must be static and identical value
4735 if not Is_Static_Subtype (T1)
4736 or else not Is_Static_Subtype (T2)
4740 -- If either type has constraint error bounds, then say that
4741 -- they match to avoid junk cascaded errors here.
4743 elsif not Is_OK_Static_Subtype (T1)
4744 or else not Is_OK_Static_Subtype (T2)
4748 elsif Is_Real_Type (T1) then
4750 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4752 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4756 Expr_Value (LB1) = Expr_Value (LB2)
4758 Expr_Value (HB1) = Expr_Value (HB2);
4763 -- Type with discriminants
4765 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
4767 -- Because of view exchanges in multiple instantiations, conformance
4768 -- checking might try to match a partial view of a type with no
4769 -- discriminants with a full view that has defaulted discriminants.
4770 -- In such a case, use the discriminant constraint of the full view,
4771 -- which must exist because we know that the two subtypes have the
4774 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
4776 if Is_Private_Type (T2)
4777 and then Present (Full_View (T2))
4778 and then Has_Discriminants (Full_View (T2))
4780 return Subtypes_Statically_Match (T1, Full_View (T2));
4782 elsif Is_Private_Type (T1)
4783 and then Present (Full_View (T1))
4784 and then Has_Discriminants (Full_View (T1))
4786 return Subtypes_Statically_Match (Full_View (T1), T2);
4797 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
4798 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
4806 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
4810 -- Now loop through the discriminant constraints
4812 -- Note: the guard here seems necessary, since it is possible at
4813 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
4815 if Present (DL1) and then Present (DL2) then
4816 DA1 := First_Elmt (DL1);
4817 DA2 := First_Elmt (DL2);
4818 while Present (DA1) loop
4820 Expr1 : constant Node_Id := Node (DA1);
4821 Expr2 : constant Node_Id := Node (DA2);
4824 if not Is_Static_Expression (Expr1)
4825 or else not Is_Static_Expression (Expr2)
4829 -- If either expression raised a constraint error,
4830 -- consider the expressions as matching, since this
4831 -- helps to prevent cascading errors.
4833 elsif Raises_Constraint_Error (Expr1)
4834 or else Raises_Constraint_Error (Expr2)
4838 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
4851 -- A definite type does not match an indefinite or classwide type.
4852 -- However, a generic type with unknown discriminants may be
4853 -- instantiated with a type with no discriminants, and conformance
4854 -- checking on an inherited operation may compare the actual with the
4855 -- subtype that renames it in the instance.
4858 Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
4861 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
4865 elsif Is_Array_Type (T1) then
4867 -- If either subtype is unconstrained then both must be, and if both
4868 -- are unconstrained then no further checking is needed.
4870 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
4871 return not (Is_Constrained (T1) or else Is_Constrained (T2));
4874 -- Both subtypes are constrained, so check that the index subtypes
4875 -- statically match.
4878 Index1 : Node_Id := First_Index (T1);
4879 Index2 : Node_Id := First_Index (T2);
4882 while Present (Index1) loop
4884 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
4889 Next_Index (Index1);
4890 Next_Index (Index2);
4896 elsif Is_Access_Type (T1) then
4897 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
4900 elsif Ekind_In (T1, E_Access_Subprogram_Type,
4901 E_Anonymous_Access_Subprogram_Type)
4905 (Designated_Type (T1),
4906 Designated_Type (T2));
4909 Subtypes_Statically_Match
4910 (Designated_Type (T1),
4911 Designated_Type (T2))
4912 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
4915 -- All other types definitely match
4920 end Subtypes_Statically_Match;
4926 function Test (Cond : Boolean) return Uint is
4935 ---------------------------------
4936 -- Test_Expression_Is_Foldable --
4937 ---------------------------------
4941 procedure Test_Expression_Is_Foldable
4951 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4955 -- If operand is Any_Type, just propagate to result and do not
4956 -- try to fold, this prevents cascaded errors.
4958 if Etype (Op1) = Any_Type then
4959 Set_Etype (N, Any_Type);
4962 -- If operand raises constraint error, then replace node N with the
4963 -- raise constraint error node, and we are obviously not foldable.
4964 -- Note that this replacement inherits the Is_Static_Expression flag
4965 -- from the operand.
4967 elsif Raises_Constraint_Error (Op1) then
4968 Rewrite_In_Raise_CE (N, Op1);
4971 -- If the operand is not static, then the result is not static, and
4972 -- all we have to do is to check the operand since it is now known
4973 -- to appear in a non-static context.
4975 elsif not Is_Static_Expression (Op1) then
4976 Check_Non_Static_Context (Op1);
4977 Fold := Compile_Time_Known_Value (Op1);
4980 -- An expression of a formal modular type is not foldable because
4981 -- the modulus is unknown.
4983 elsif Is_Modular_Integer_Type (Etype (Op1))
4984 and then Is_Generic_Type (Etype (Op1))
4986 Check_Non_Static_Context (Op1);
4989 -- Here we have the case of an operand whose type is OK, which is
4990 -- static, and which does not raise constraint error, we can fold.
4993 Set_Is_Static_Expression (N);
4997 end Test_Expression_Is_Foldable;
5001 procedure Test_Expression_Is_Foldable
5008 Rstat : constant Boolean := Is_Static_Expression (Op1)
5009 and then Is_Static_Expression (Op2);
5015 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
5019 -- If either operand is Any_Type, just propagate to result and
5020 -- do not try to fold, this prevents cascaded errors.
5022 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
5023 Set_Etype (N, Any_Type);
5026 -- If left operand raises constraint error, then replace node N with the
5027 -- Raise_Constraint_Error node, and we are obviously not foldable.
5028 -- Is_Static_Expression is set from the two operands in the normal way,
5029 -- and we check the right operand if it is in a non-static context.
5031 elsif Raises_Constraint_Error (Op1) then
5033 Check_Non_Static_Context (Op2);
5036 Rewrite_In_Raise_CE (N, Op1);
5037 Set_Is_Static_Expression (N, Rstat);
5040 -- Similar processing for the case of the right operand. Note that we
5041 -- don't use this routine for the short-circuit case, so we do not have
5042 -- to worry about that special case here.
5044 elsif Raises_Constraint_Error (Op2) then
5046 Check_Non_Static_Context (Op1);
5049 Rewrite_In_Raise_CE (N, Op2);
5050 Set_Is_Static_Expression (N, Rstat);
5053 -- Exclude expressions of a generic modular type, as above
5055 elsif Is_Modular_Integer_Type (Etype (Op1))
5056 and then Is_Generic_Type (Etype (Op1))
5058 Check_Non_Static_Context (Op1);
5061 -- If result is not static, then check non-static contexts on operands
5062 -- since one of them may be static and the other one may not be static.
5064 elsif not Rstat then
5065 Check_Non_Static_Context (Op1);
5066 Check_Non_Static_Context (Op2);
5067 Fold := Compile_Time_Known_Value (Op1)
5068 and then Compile_Time_Known_Value (Op2);
5071 -- Else result is static and foldable. Both operands are static, and
5072 -- neither raises constraint error, so we can definitely fold.
5075 Set_Is_Static_Expression (N);
5080 end Test_Expression_Is_Foldable;
5086 function Test_In_Range
5089 Assume_Valid : Boolean;
5090 Fixed_Int : Boolean;
5091 Int_Real : Boolean) return Range_Membership
5096 pragma Warnings (Off, Assume_Valid);
5097 -- For now Assume_Valid is unreferenced since the current implementation
5098 -- always returns Unknown if N is not a compile time known value, but we
5099 -- keep the parameter to allow for future enhancements in which we try
5100 -- to get the information in the variable case as well.
5103 -- Universal types have no range limits, so always in range
5105 if Typ = Universal_Integer or else Typ = Universal_Real then
5108 -- Never known if not scalar type. Don't know if this can actually
5109 -- happen, but our spec allows it, so we must check!
5111 elsif not Is_Scalar_Type (Typ) then
5114 -- Never known if this is a generic type, since the bounds of generic
5115 -- types are junk. Note that if we only checked for static expressions
5116 -- (instead of compile time known values) below, we would not need this
5117 -- check, because values of a generic type can never be static, but they
5118 -- can be known at compile time.
5120 elsif Is_Generic_Type (Typ) then
5123 -- Never known unless we have a compile time known value
5125 elsif not Compile_Time_Known_Value (N) then
5128 -- General processing with a known compile time value
5139 Lo := Type_Low_Bound (Typ);
5140 Hi := Type_High_Bound (Typ);
5142 LB_Known := Compile_Time_Known_Value (Lo);
5143 HB_Known := Compile_Time_Known_Value (Hi);
5145 -- Fixed point types should be considered as such only if flag
5146 -- Fixed_Int is set to False.
5148 if Is_Floating_Point_Type (Typ)
5149 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
5152 Valr := Expr_Value_R (N);
5154 if LB_Known and HB_Known then
5155 if Valr >= Expr_Value_R (Lo)
5157 Valr <= Expr_Value_R (Hi)
5161 return Out_Of_Range;
5164 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
5166 (HB_Known and then Valr > Expr_Value_R (Hi))
5168 return Out_Of_Range;
5175 Val := Expr_Value (N);
5177 if LB_Known and HB_Known then
5178 if Val >= Expr_Value (Lo)
5180 Val <= Expr_Value (Hi)
5184 return Out_Of_Range;
5187 elsif (LB_Known and then Val < Expr_Value (Lo))
5189 (HB_Known and then Val > Expr_Value (Hi))
5191 return Out_Of_Range;
5205 procedure To_Bits (U : Uint; B : out Bits) is
5207 for J in 0 .. B'Last loop
5208 B (J) := (U / (2 ** J)) mod 2 /= 0;
5212 --------------------
5213 -- Why_Not_Static --
5214 --------------------
5216 procedure Why_Not_Static (Expr : Node_Id) is
5217 N : constant Node_Id := Original_Node (Expr);
5221 procedure Why_Not_Static_List (L : List_Id);
5222 -- A version that can be called on a list of expressions. Finds all
5223 -- non-static violations in any element of the list.
5225 -------------------------
5226 -- Why_Not_Static_List --
5227 -------------------------
5229 procedure Why_Not_Static_List (L : List_Id) is
5233 if Is_Non_Empty_List (L) then
5235 while Present (N) loop
5240 end Why_Not_Static_List;
5242 -- Start of processing for Why_Not_Static
5245 -- If in ACATS mode (debug flag 2), then suppress all these messages,
5246 -- this avoids massive updates to the ACATS base line.
5248 if Debug_Flag_2 then
5252 -- Ignore call on error or empty node
5254 if No (Expr) or else Nkind (Expr) = N_Error then
5258 -- Preprocessing for sub expressions
5260 if Nkind (Expr) in N_Subexpr then
5262 -- Nothing to do if expression is static
5264 if Is_OK_Static_Expression (Expr) then
5268 -- Test for constraint error raised
5270 if Raises_Constraint_Error (Expr) then
5272 ("expression raises exception, cannot be static " &
5273 "(RM 4.9(34))!", N);
5277 -- If no type, then something is pretty wrong, so ignore
5279 Typ := Etype (Expr);
5285 -- Type must be scalar or string type
5287 if not Is_Scalar_Type (Typ)
5288 and then not Is_String_Type (Typ)
5291 ("static expression must have scalar or string type " &
5297 -- If we got through those checks, test particular node kind
5300 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
5303 if Is_Named_Number (E) then
5306 elsif Ekind (E) = E_Constant then
5307 if not Is_Static_Expression (Constant_Value (E)) then
5309 ("& is not a static constant (RM 4.9(5))!", N, E);
5314 ("& is not static constant or named number " &
5315 "(RM 4.9(5))!", N, E);
5318 when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
5319 if Nkind (N) in N_Op_Shift then
5321 ("shift functions are never static (RM 4.9(6,18))!", N);
5324 Why_Not_Static (Left_Opnd (N));
5325 Why_Not_Static (Right_Opnd (N));
5329 Why_Not_Static (Right_Opnd (N));
5331 when N_Attribute_Reference =>
5332 Why_Not_Static_List (Expressions (N));
5334 E := Etype (Prefix (N));
5336 if E = Standard_Void_Type then
5340 -- Special case non-scalar'Size since this is a common error
5342 if Attribute_Name (N) = Name_Size then
5344 ("size attribute is only static for static scalar type " &
5345 "(RM 4.9(7,8))", N);
5349 elsif Is_Array_Type (E) then
5350 if Attribute_Name (N) /= Name_First
5352 Attribute_Name (N) /= Name_Last
5354 Attribute_Name (N) /= Name_Length
5357 ("static array attribute must be Length, First, or Last " &
5360 -- Since we know the expression is not-static (we already
5361 -- tested for this, must mean array is not static).
5365 ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
5370 -- Special case generic types, since again this is a common source
5373 elsif Is_Generic_Actual_Type (E)
5378 ("attribute of generic type is never static " &
5379 "(RM 4.9(7,8))!", N);
5381 elsif Is_Static_Subtype (E) then
5384 elsif Is_Scalar_Type (E) then
5386 ("prefix type for attribute is not static scalar subtype " &
5391 ("static attribute must apply to array/scalar type " &
5392 "(RM 4.9(7,8))!", N);
5395 when N_String_Literal =>
5397 ("subtype of string literal is non-static (RM 4.9(4))!", N);
5399 when N_Explicit_Dereference =>
5401 ("explicit dereference is never static (RM 4.9)!", N);
5403 when N_Function_Call =>
5404 Why_Not_Static_List (Parameter_Associations (N));
5405 Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
5407 when N_Parameter_Association =>
5408 Why_Not_Static (Explicit_Actual_Parameter (N));
5410 when N_Indexed_Component =>
5412 ("indexed component is never static (RM 4.9)!", N);
5414 when N_Procedure_Call_Statement =>
5416 ("procedure call is never static (RM 4.9)!", N);
5418 when N_Qualified_Expression =>
5419 Why_Not_Static (Expression (N));
5421 when N_Aggregate | N_Extension_Aggregate =>
5423 ("an aggregate is never static (RM 4.9)!", N);
5426 Why_Not_Static (Low_Bound (N));
5427 Why_Not_Static (High_Bound (N));
5429 when N_Range_Constraint =>
5430 Why_Not_Static (Range_Expression (N));
5432 when N_Subtype_Indication =>
5433 Why_Not_Static (Constraint (N));
5435 when N_Selected_Component =>
5437 ("selected component is never static (RM 4.9)!", N);
5441 ("slice is never static (RM 4.9)!", N);
5443 when N_Type_Conversion =>
5444 Why_Not_Static (Expression (N));
5446 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
5447 or else not Is_Static_Subtype (Entity (Subtype_Mark (N)))
5450 ("static conversion requires static scalar subtype result " &
5454 when N_Unchecked_Type_Conversion =>
5456 ("unchecked type conversion is never static (RM 4.9)!", N);