1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 comaprison, 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 or error types
255 if T = Any_Type or else not Is_Scalar_Type (T) then
259 -- At this stage we have a scalar type. If we have an expression
260 -- that raises CE, then we already issued a warning or error msg
261 -- so there is nothing more to be done in this routine.
263 if Raises_Constraint_Error (N) then
267 -- Now we have a scalar type which is not marked as raising a
268 -- constraint error exception. The main purpose of this routine
269 -- is to deal with static expressions appearing in a non-static
270 -- context. That means that if we do not have a static expression
271 -- then there is not much to do. The one case that we deal with
272 -- here is that if we have a floating-point value that is out of
273 -- range, then we post a warning that an infinity will result.
275 if not Is_Static_Expression (N) then
276 if Is_Floating_Point_Type (T)
277 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
280 ("?float value out of range, infinity will be generated", N);
286 -- Here we have the case of outer level static expression of
287 -- scalar type, where the processing of this procedure is needed.
289 -- For real types, this is where we convert the value to a machine
290 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should
291 -- only need to do this if the parent is a constant declaration,
292 -- since in other cases, gigi should do the necessary conversion
293 -- correctly, but experimentation shows that this is not the case
294 -- on all machines, in particular if we do not convert all literals
295 -- to machine values in non-static contexts, then ACVC test C490001
296 -- fails on Sparc/Solaris and SGI/Irix.
298 if Nkind (N) = N_Real_Literal
299 and then not Is_Machine_Number (N)
300 and then not Is_Generic_Type (Etype (N))
301 and then Etype (N) /= Universal_Real
303 -- Check that value is in bounds before converting to machine
304 -- number, so as not to lose case where value overflows in the
305 -- least significant bit or less. See B490001.
307 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
312 -- Note: we have to copy the node, to avoid problems with conformance
313 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
315 Rewrite (N, New_Copy (N));
317 if not Is_Floating_Point_Type (T) then
319 (N, Corresponding_Integer_Value (N) * Small_Value (T));
321 elsif not UR_Is_Zero (Realval (N)) then
323 -- Note: even though RM 4.9(38) specifies biased rounding,
324 -- this has been modified by AI-100 in order to prevent
325 -- confusing differences in rounding between static and
326 -- non-static expressions. AI-100 specifies that the effect
327 -- of such rounding is implementation dependent, and in GNAT
328 -- we round to nearest even to match the run-time behavior.
331 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
334 Set_Is_Machine_Number (N);
337 -- Check for out of range universal integer. This is a non-static
338 -- context, so the integer value must be in range of the runtime
339 -- representation of universal integers.
341 -- We do this only within an expression, because that is the only
342 -- case in which non-static universal integer values can occur, and
343 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
344 -- called in contexts like the expression of a number declaration where
345 -- we certainly want to allow out of range values.
347 if Etype (N) = Universal_Integer
348 and then Nkind (N) = N_Integer_Literal
349 and then Nkind (Parent (N)) in N_Subexpr
351 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
353 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
355 Apply_Compile_Time_Constraint_Error
356 (N, "non-static universal integer value out of range?",
357 CE_Range_Check_Failed);
359 -- Check out of range of base type
361 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
364 -- Give warning if outside subtype (where one or both of the bounds of
365 -- the subtype is static). This warning is omitted if the expression
366 -- appears in a range that could be null (warnings are handled elsewhere
369 elsif T /= Base_Type (T)
370 and then Nkind (Parent (N)) /= N_Range
372 if Is_In_Range (N, T, Assume_Valid => True) then
375 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
376 Apply_Compile_Time_Constraint_Error
377 (N, "value not in range of}?", CE_Range_Check_Failed);
380 Enable_Range_Check (N);
383 Set_Do_Range_Check (N, False);
386 end Check_Non_Static_Context;
388 ---------------------------------
389 -- Check_String_Literal_Length --
390 ---------------------------------
392 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
394 if not Raises_Constraint_Error (N)
395 and then Is_Constrained (Ttype)
398 UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
400 Apply_Compile_Time_Constraint_Error
401 (N, "string length wrong for}?",
402 CE_Length_Check_Failed,
407 end Check_String_Literal_Length;
409 --------------------------
410 -- Compile_Time_Compare --
411 --------------------------
413 function Compile_Time_Compare
415 Assume_Valid : Boolean) return Compare_Result
417 Discard : aliased Uint;
419 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
420 end Compile_Time_Compare;
422 function Compile_Time_Compare
425 Assume_Valid : Boolean;
426 Rec : Boolean := False) return Compare_Result
428 Ltyp : Entity_Id := Underlying_Type (Etype (L));
429 Rtyp : Entity_Id := Underlying_Type (Etype (R));
430 -- These get reset to the base type for the case of entities where
431 -- Is_Known_Valid is not set. This takes care of handling possible
432 -- invalid representations using the value of the base type, in
433 -- accordance with RM 13.9.1(10).
435 Discard : aliased Uint;
437 procedure Compare_Decompose
441 -- This procedure decomposes the node N into an expression node and a
442 -- signed offset, so that the value of N is equal to the value of R plus
443 -- the value V (which may be negative). If no such decomposition is
444 -- possible, then on return R is a copy of N, and V is set to zero.
446 function Compare_Fixup (N : Node_Id) return Node_Id;
447 -- This function deals with replacing 'Last and 'First references with
448 -- their corresponding type bounds, which we then can compare. The
449 -- argument is the original node, the result is the identity, unless we
450 -- have a 'Last/'First reference in which case the value returned is the
451 -- appropriate type bound.
453 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
454 -- Even if the context does not assume that values are valid, some
455 -- simple cases can be recognized.
457 function Is_Same_Value (L, R : Node_Id) return Boolean;
458 -- Returns True iff L and R represent expressions that definitely
459 -- have identical (but not necessarily compile time known) values
460 -- Indeed the caller is expected to have already dealt with the
461 -- cases of compile time known values, so these are not tested here.
463 -----------------------
464 -- Compare_Decompose --
465 -----------------------
467 procedure Compare_Decompose
473 if Nkind (N) = N_Op_Add
474 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
477 V := Intval (Right_Opnd (N));
480 elsif Nkind (N) = N_Op_Subtract
481 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
484 V := UI_Negate (Intval (Right_Opnd (N)));
487 elsif Nkind (N) = N_Attribute_Reference then
488 if Attribute_Name (N) = Name_Succ then
489 R := First (Expressions (N));
493 elsif Attribute_Name (N) = Name_Pred then
494 R := First (Expressions (N));
502 end Compare_Decompose;
508 function Compare_Fixup (N : Node_Id) return Node_Id is
514 if Nkind (N) = N_Attribute_Reference
515 and then (Attribute_Name (N) = Name_First
517 Attribute_Name (N) = Name_Last)
519 Xtyp := Etype (Prefix (N));
521 -- If we have no type, then just abandon the attempt to do
522 -- a fixup, this is probably the result of some other error.
528 -- Dereference an access type
530 if Is_Access_Type (Xtyp) then
531 Xtyp := Designated_Type (Xtyp);
534 -- If we don't have an array type at this stage, something
535 -- is peculiar, e.g. another error, and we abandon the attempt
538 if not Is_Array_Type (Xtyp) then
542 -- Ignore unconstrained array, since bounds are not meaningful
544 if not Is_Constrained (Xtyp) then
548 if Ekind (Xtyp) = E_String_Literal_Subtype then
549 if Attribute_Name (N) = Name_First then
550 return String_Literal_Low_Bound (Xtyp);
552 else -- Attribute_Name (N) = Name_Last
553 return Make_Integer_Literal (Sloc (N),
554 Intval => Intval (String_Literal_Low_Bound (Xtyp))
555 + String_Literal_Length (Xtyp));
559 -- Find correct index type
561 Indx := First_Index (Xtyp);
563 if Present (Expressions (N)) then
564 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
566 for J in 2 .. Subs loop
567 Indx := Next_Index (Indx);
571 Xtyp := Etype (Indx);
573 if Attribute_Name (N) = Name_First then
574 return Type_Low_Bound (Xtyp);
576 else -- Attribute_Name (N) = Name_Last
577 return Type_High_Bound (Xtyp);
584 ----------------------------
585 -- Is_Known_Valid_Operand --
586 ----------------------------
588 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
590 return (Is_Entity_Name (Opnd)
592 (Is_Known_Valid (Entity (Opnd))
593 or else Ekind (Entity (Opnd)) = E_In_Parameter
595 (Ekind (Entity (Opnd)) in Object_Kind
596 and then Present (Current_Value (Entity (Opnd))))))
597 or else Is_OK_Static_Expression (Opnd);
598 end Is_Known_Valid_Operand;
604 function Is_Same_Value (L, R : Node_Id) return Boolean is
605 Lf : constant Node_Id := Compare_Fixup (L);
606 Rf : constant Node_Id := Compare_Fixup (R);
608 function Is_Same_Subscript (L, R : List_Id) return Boolean;
609 -- L, R are the Expressions values from two attribute nodes for First
610 -- or Last attributes. Either may be set to No_List if no expressions
611 -- are present (indicating subscript 1). The result is True if both
612 -- expressions represent the same subscript (note one case is where
613 -- one subscript is missing and the other is explicitly set to 1).
615 -----------------------
616 -- Is_Same_Subscript --
617 -----------------------
619 function Is_Same_Subscript (L, R : List_Id) return Boolean is
625 return Expr_Value (First (R)) = Uint_1;
630 return Expr_Value (First (L)) = Uint_1;
632 return Expr_Value (First (L)) = Expr_Value (First (R));
635 end Is_Same_Subscript;
637 -- Start of processing for Is_Same_Value
640 -- Values are the same if they refer to the same entity and the
641 -- entity is non-volatile. This does not however apply to Float
642 -- types, since we may have two NaN values and they should never
645 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
646 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
647 and then Entity (Lf) = Entity (Rf)
648 and then Present (Entity (Lf))
649 and then not Is_Floating_Point_Type (Etype (L))
650 and then not Is_Volatile_Reference (L)
651 and then not Is_Volatile_Reference (R)
655 -- Or if they are compile time known and identical
657 elsif Compile_Time_Known_Value (Lf)
659 Compile_Time_Known_Value (Rf)
660 and then Expr_Value (Lf) = Expr_Value (Rf)
664 -- False if Nkind of the two nodes is different for remaining cases
666 elsif Nkind (Lf) /= Nkind (Rf) then
669 -- True if both 'First or 'Last values applying to the same entity
670 -- (first and last don't change even if value does). Note that we
671 -- need this even with the calls to Compare_Fixup, to handle the
672 -- case of unconstrained array attributes where Compare_Fixup
673 -- cannot find useful bounds.
675 elsif Nkind (Lf) = N_Attribute_Reference
676 and then Attribute_Name (Lf) = Attribute_Name (Rf)
677 and then (Attribute_Name (Lf) = Name_First
679 Attribute_Name (Lf) = Name_Last)
680 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
681 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
682 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
683 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
687 -- True if the same selected component from the same record
689 elsif Nkind (Lf) = N_Selected_Component
690 and then Selector_Name (Lf) = Selector_Name (Rf)
691 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
695 -- True if the same unary operator applied to the same operand
697 elsif Nkind (Lf) in N_Unary_Op
698 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
702 -- True if the same binary operator applied to the same operands
704 elsif Nkind (Lf) in N_Binary_Op
705 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
706 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
710 -- All other cases, we can't tell, so return False
717 -- Start of processing for Compile_Time_Compare
722 -- If either operand could raise constraint error, then we cannot
723 -- know the result at compile time (since CE may be raised!)
725 if not (Cannot_Raise_Constraint_Error (L)
727 Cannot_Raise_Constraint_Error (R))
732 -- Identical operands are most certainly equal
737 -- If expressions have no types, then do not attempt to determine if
738 -- they are the same, since something funny is going on. One case in
739 -- which this happens is during generic template analysis, when bounds
740 -- are not fully analyzed.
742 elsif No (Ltyp) or else No (Rtyp) then
745 -- We do not attempt comparisons for packed arrays arrays represented as
746 -- modular types, where the semantics of comparison is quite different.
748 elsif Is_Packed_Array_Type (Ltyp)
749 and then Is_Modular_Integer_Type (Ltyp)
753 -- For access types, the only time we know the result at compile time
754 -- (apart from identical operands, which we handled already) is if we
755 -- know one operand is null and the other is not, or both operands are
758 elsif Is_Access_Type (Ltyp) then
759 if Known_Null (L) then
760 if Known_Null (R) then
762 elsif Known_Non_Null (R) then
768 elsif Known_Non_Null (L) and then Known_Null (R) then
775 -- Case where comparison involves two compile time known values
777 elsif Compile_Time_Known_Value (L)
778 and then Compile_Time_Known_Value (R)
780 -- For the floating-point case, we have to be a little careful, since
781 -- at compile time we are dealing with universal exact values, but at
782 -- runtime, these will be in non-exact target form. That's why the
783 -- returned results are LE and GE below instead of LT and GT.
785 if Is_Floating_Point_Type (Ltyp)
787 Is_Floating_Point_Type (Rtyp)
790 Lo : constant Ureal := Expr_Value_R (L);
791 Hi : constant Ureal := Expr_Value_R (R);
803 -- For string types, we have two string literals and we proceed to
804 -- compare them using the Ada style dictionary string comparison.
806 elsif not Is_Scalar_Type (Ltyp) then
808 Lstring : constant String_Id := Strval (Expr_Value_S (L));
809 Rstring : constant String_Id := Strval (Expr_Value_S (R));
810 Llen : constant Nat := String_Length (Lstring);
811 Rlen : constant Nat := String_Length (Rstring);
814 for J in 1 .. Nat'Min (Llen, Rlen) loop
816 LC : constant Char_Code := Get_String_Char (Lstring, J);
817 RC : constant Char_Code := Get_String_Char (Rstring, J);
829 elsif Llen > Rlen then
836 -- For remaining scalar cases we know exactly (note that this does
837 -- include the fixed-point case, where we know the run time integer
842 Lo : constant Uint := Expr_Value (L);
843 Hi : constant Uint := Expr_Value (R);
860 -- Cases where at least one operand is not known at compile time
863 -- Remaining checks apply only for discrete types
865 if not Is_Discrete_Type (Ltyp)
866 or else not Is_Discrete_Type (Rtyp)
871 -- Defend against generic types, or actually any expressions that
872 -- contain a reference to a generic type from within a generic
873 -- template. We don't want to do any range analysis of such
874 -- expressions for two reasons. First, the bounds of a generic type
875 -- itself are junk and cannot be used for any kind of analysis.
876 -- Second, we may have a case where the range at run time is indeed
877 -- known, but we don't want to do compile time analysis in the
878 -- template based on that range since in an instance the value may be
879 -- static, and able to be elaborated without reference to the bounds
880 -- of types involved. As an example, consider:
882 -- (F'Pos (F'Last) + 1) > Integer'Last
884 -- The expression on the left side of > is Universal_Integer and thus
885 -- acquires the type Integer for evaluation at run time, and at run
886 -- time it is true that this condition is always False, but within
887 -- an instance F may be a type with a static range greater than the
888 -- range of Integer, and the expression statically evaluates to True.
890 if References_Generic_Formal_Type (L)
892 References_Generic_Formal_Type (R)
897 -- Replace types by base types for the case of entities which are
898 -- not known to have valid representations. This takes care of
899 -- properly dealing with invalid representations.
901 if not Assume_Valid and then not Assume_No_Invalid_Values then
902 if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
903 Ltyp := Underlying_Type (Base_Type (Ltyp));
906 if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
907 Rtyp := Underlying_Type (Base_Type (Rtyp));
911 -- Try range analysis on variables and see if ranges are disjoint
919 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
920 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
934 -- If the range includes a single literal and we can assume
935 -- validity then the result is known even if an operand is
950 elsif not Is_Known_Valid_Operand (L)
951 and then not Assume_Valid
953 if Is_Same_Value (L, R) then
962 -- Here is where we check for comparisons against maximum bounds of
963 -- types, where we know that no value can be outside the bounds of
964 -- the subtype. Note that this routine is allowed to assume that all
965 -- expressions are within their subtype bounds. Callers wishing to
966 -- deal with possibly invalid values must in any case take special
967 -- steps (e.g. conversions to larger types) to avoid this kind of
968 -- optimization, which is always considered to be valid. We do not
969 -- attempt this optimization with generic types, since the type
970 -- bounds may not be meaningful in this case.
972 -- We are in danger of an infinite recursion here. It does not seem
973 -- useful to go more than one level deep, so the parameter Rec is
974 -- used to protect ourselves against this infinite recursion.
978 -- See if we can get a decisive check against one operand and
979 -- a bound of the other operand (four possible tests here).
980 -- Note that we avoid testing junk bounds of a generic type.
982 if not Is_Generic_Type (Rtyp) then
983 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
985 Assume_Valid, Rec => True)
987 when LT => return LT;
988 when LE => return LE;
989 when EQ => return LE;
993 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
995 Assume_Valid, Rec => True)
997 when GT => return GT;
998 when GE => return GE;
999 when EQ => return GE;
1000 when others => null;
1004 if not Is_Generic_Type (Ltyp) then
1005 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1007 Assume_Valid, Rec => True)
1009 when GT => return GT;
1010 when GE => return GE;
1011 when EQ => return GE;
1012 when others => null;
1015 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1017 Assume_Valid, Rec => True)
1019 when LT => return LT;
1020 when LE => return LE;
1021 when EQ => return LE;
1022 when others => null;
1027 -- Next attempt is to decompose the expressions to extract
1028 -- a constant offset resulting from the use of any of the forms:
1035 -- Then we see if the two expressions are the same value, and if so
1036 -- the result is obtained by comparing the offsets.
1045 Compare_Decompose (L, Lnode, Loffs);
1046 Compare_Decompose (R, Rnode, Roffs);
1048 if Is_Same_Value (Lnode, Rnode) then
1049 if Loffs = Roffs then
1052 elsif Loffs < Roffs then
1053 Diff.all := Roffs - Loffs;
1057 Diff.all := Loffs - Roffs;
1063 -- Next attempt is to see if we have an entity compared with a
1064 -- compile time known value, where there is a current value
1065 -- conditional for the entity which can tell us the result.
1069 -- Entity variable (left operand)
1072 -- Value (right operand)
1075 -- If False, we have reversed the operands
1078 -- Comparison operator kind from Get_Current_Value_Condition call
1081 -- Value from Get_Current_Value_Condition call
1086 Result : Compare_Result;
1087 -- Known result before inversion
1090 if Is_Entity_Name (L)
1091 and then Compile_Time_Known_Value (R)
1094 Val := Expr_Value (R);
1097 elsif Is_Entity_Name (R)
1098 and then Compile_Time_Known_Value (L)
1101 Val := Expr_Value (L);
1104 -- That was the last chance at finding a compile time result
1110 Get_Current_Value_Condition (Var, Op, Opn);
1112 -- That was the last chance, so if we got nothing return
1118 Opv := Expr_Value (Opn);
1120 -- We got a comparison, so we might have something interesting
1122 -- Convert LE to LT and GE to GT, just so we have fewer cases
1124 if Op = N_Op_Le then
1128 elsif Op = N_Op_Ge then
1133 -- Deal with equality case
1135 if Op = N_Op_Eq then
1138 elsif Opv < Val then
1144 -- Deal with inequality case
1146 elsif Op = N_Op_Ne then
1153 -- Deal with greater than case
1155 elsif Op = N_Op_Gt then
1158 elsif Opv = Val - 1 then
1164 -- Deal with less than case
1166 else pragma Assert (Op = N_Op_Lt);
1169 elsif Opv = Val + 1 then
1176 -- Deal with inverting result
1180 when GT => return LT;
1181 when GE => return LE;
1182 when LT => return GT;
1183 when LE => return GE;
1184 when others => return Result;
1191 end Compile_Time_Compare;
1193 -------------------------------
1194 -- Compile_Time_Known_Bounds --
1195 -------------------------------
1197 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1202 if not Is_Array_Type (T) then
1206 Indx := First_Index (T);
1207 while Present (Indx) loop
1208 Typ := Underlying_Type (Etype (Indx));
1210 -- Never look at junk bounds of a generic type
1212 if Is_Generic_Type (Typ) then
1216 -- Otherwise check bounds for compile time known
1218 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1220 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1228 end Compile_Time_Known_Bounds;
1230 ------------------------------
1231 -- Compile_Time_Known_Value --
1232 ------------------------------
1234 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1235 K : constant Node_Kind := Nkind (Op);
1236 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1239 -- Never known at compile time if bad type or raises constraint error
1240 -- or empty (latter case occurs only as a result of a previous error)
1244 or else Etype (Op) = Any_Type
1245 or else Raises_Constraint_Error (Op)
1250 -- If this is not a static expression or a null literal, and we are in
1251 -- configurable run-time mode, then we consider it not known at compile
1252 -- time. This avoids anomalies where whether something is allowed with a
1253 -- given configurable run-time library depends on how good the compiler
1254 -- is at optimizing and knowing that things are constant when they are
1257 if Configurable_Run_Time_Mode
1258 and then K /= N_Null
1259 and then not Is_Static_Expression (Op)
1264 -- If we have an entity name, then see if it is the name of a constant
1265 -- and if so, test the corresponding constant value, or the name of
1266 -- an enumeration literal, which is always a constant.
1268 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1270 E : constant Entity_Id := Entity (Op);
1274 -- Never known at compile time if it is a packed array value.
1275 -- We might want to try to evaluate these at compile time one
1276 -- day, but we do not make that attempt now.
1278 if Is_Packed_Array_Type (Etype (Op)) then
1282 if Ekind (E) = E_Enumeration_Literal then
1285 elsif Ekind (E) = E_Constant then
1286 V := Constant_Value (E);
1287 return Present (V) and then Compile_Time_Known_Value (V);
1291 -- We have a value, see if it is compile time known
1294 -- Integer literals are worth storing in the cache
1296 if K = N_Integer_Literal then
1298 CV_Ent.V := Intval (Op);
1301 -- Other literals and NULL are known at compile time
1304 K = N_Character_Literal
1308 K = N_String_Literal
1314 -- Any reference to Null_Parameter is known at compile time. No
1315 -- other attribute references (that have not already been folded)
1316 -- are known at compile time.
1318 elsif K = N_Attribute_Reference then
1319 return Attribute_Name (Op) = Name_Null_Parameter;
1323 -- If we fall through, not known at compile time
1327 -- If we get an exception while trying to do this test, then some error
1328 -- has occurred, and we simply say that the value is not known after all
1333 end Compile_Time_Known_Value;
1335 --------------------------------------
1336 -- Compile_Time_Known_Value_Or_Aggr --
1337 --------------------------------------
1339 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1341 -- If we have an entity name, then see if it is the name of a constant
1342 -- and if so, test the corresponding constant value, or the name of
1343 -- an enumeration literal, which is always a constant.
1345 if Is_Entity_Name (Op) then
1347 E : constant Entity_Id := Entity (Op);
1351 if Ekind (E) = E_Enumeration_Literal then
1354 elsif Ekind (E) /= E_Constant then
1358 V := Constant_Value (E);
1360 and then Compile_Time_Known_Value_Or_Aggr (V);
1364 -- We have a value, see if it is compile time known
1367 if Compile_Time_Known_Value (Op) then
1370 elsif Nkind (Op) = N_Aggregate then
1372 if Present (Expressions (Op)) then
1377 Expr := First (Expressions (Op));
1378 while Present (Expr) loop
1379 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1388 if Present (Component_Associations (Op)) then
1393 Cass := First (Component_Associations (Op));
1394 while Present (Cass) loop
1396 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1408 -- All other types of values are not known at compile time
1415 end Compile_Time_Known_Value_Or_Aggr;
1421 -- This is only called for actuals of functions that are not predefined
1422 -- operators (which have already been rewritten as operators at this
1423 -- stage), so the call can never be folded, and all that needs doing for
1424 -- the actual is to do the check for a non-static context.
1426 procedure Eval_Actual (N : Node_Id) is
1428 Check_Non_Static_Context (N);
1431 --------------------
1432 -- Eval_Allocator --
1433 --------------------
1435 -- Allocators are never static, so all we have to do is to do the
1436 -- check for a non-static context if an expression is present.
1438 procedure Eval_Allocator (N : Node_Id) is
1439 Expr : constant Node_Id := Expression (N);
1442 if Nkind (Expr) = N_Qualified_Expression then
1443 Check_Non_Static_Context (Expression (Expr));
1447 ------------------------
1448 -- Eval_Arithmetic_Op --
1449 ------------------------
1451 -- Arithmetic operations are static functions, so the result is static
1452 -- if both operands are static (RM 4.9(7), 4.9(20)).
1454 procedure Eval_Arithmetic_Op (N : Node_Id) is
1455 Left : constant Node_Id := Left_Opnd (N);
1456 Right : constant Node_Id := Right_Opnd (N);
1457 Ltype : constant Entity_Id := Etype (Left);
1458 Rtype : constant Entity_Id := Etype (Right);
1459 Otype : Entity_Id := Empty;
1464 -- If not foldable we are done
1466 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1472 if Is_Universal_Numeric_Type (Etype (Left))
1474 Is_Universal_Numeric_Type (Etype (Right))
1476 Otype := Find_Universal_Operator_Type (N);
1479 -- Fold for cases where both operands are of integer type
1481 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1483 Left_Int : constant Uint := Expr_Value (Left);
1484 Right_Int : constant Uint := Expr_Value (Right);
1491 Result := Left_Int + Right_Int;
1493 when N_Op_Subtract =>
1494 Result := Left_Int - Right_Int;
1496 when N_Op_Multiply =>
1499 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1501 Result := Left_Int * Right_Int;
1508 -- The exception Constraint_Error is raised by integer
1509 -- division, rem and mod if the right operand is zero.
1511 if Right_Int = 0 then
1512 Apply_Compile_Time_Constraint_Error
1513 (N, "division by zero",
1519 Result := Left_Int / Right_Int;
1524 -- The exception Constraint_Error is raised by integer
1525 -- division, rem and mod if the right operand is zero.
1527 if Right_Int = 0 then
1528 Apply_Compile_Time_Constraint_Error
1529 (N, "mod with zero divisor",
1534 Result := Left_Int mod Right_Int;
1539 -- The exception Constraint_Error is raised by integer
1540 -- division, rem and mod if the right operand is zero.
1542 if Right_Int = 0 then
1543 Apply_Compile_Time_Constraint_Error
1544 (N, "rem with zero divisor",
1550 Result := Left_Int rem Right_Int;
1554 raise Program_Error;
1557 -- Adjust the result by the modulus if the type is a modular type
1559 if Is_Modular_Integer_Type (Ltype) then
1560 Result := Result mod Modulus (Ltype);
1562 -- For a signed integer type, check non-static overflow
1564 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1566 BT : constant Entity_Id := Base_Type (Ltype);
1567 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1568 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1570 if Result < Lo or else Result > Hi then
1571 Apply_Compile_Time_Constraint_Error
1572 (N, "value not in range of }?",
1573 CE_Overflow_Check_Failed,
1580 -- If we get here we can fold the result
1582 Fold_Uint (N, Result, Stat);
1585 -- Cases where at least one operand is a real. We handle the cases of
1586 -- both reals, or mixed/real integer cases (the latter happen only for
1587 -- divide and multiply, and the result is always real).
1589 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1596 if Is_Real_Type (Ltype) then
1597 Left_Real := Expr_Value_R (Left);
1599 Left_Real := UR_From_Uint (Expr_Value (Left));
1602 if Is_Real_Type (Rtype) then
1603 Right_Real := Expr_Value_R (Right);
1605 Right_Real := UR_From_Uint (Expr_Value (Right));
1608 if Nkind (N) = N_Op_Add then
1609 Result := Left_Real + Right_Real;
1611 elsif Nkind (N) = N_Op_Subtract then
1612 Result := Left_Real - Right_Real;
1614 elsif Nkind (N) = N_Op_Multiply then
1615 Result := Left_Real * Right_Real;
1617 else pragma Assert (Nkind (N) = N_Op_Divide);
1618 if UR_Is_Zero (Right_Real) then
1619 Apply_Compile_Time_Constraint_Error
1620 (N, "division by zero", CE_Divide_By_Zero);
1624 Result := Left_Real / Right_Real;
1627 Fold_Ureal (N, Result, Stat);
1631 -- If the operator was resolved to a specific type, make sure that type
1632 -- is frozen even if the expression is folded into a literal (which has
1633 -- a universal type).
1635 if Present (Otype) then
1636 Freeze_Before (N, Otype);
1638 end Eval_Arithmetic_Op;
1640 ----------------------------
1641 -- Eval_Character_Literal --
1642 ----------------------------
1644 -- Nothing to be done!
1646 procedure Eval_Character_Literal (N : Node_Id) is
1647 pragma Warnings (Off, N);
1650 end Eval_Character_Literal;
1656 -- Static function calls are either calls to predefined operators
1657 -- with static arguments, or calls to functions that rename a literal.
1658 -- Only the latter case is handled here, predefined operators are
1659 -- constant-folded elsewhere.
1661 -- If the function is itself inherited (see 7423-001) the literal of
1662 -- the parent type must be explicitly converted to the return type
1665 procedure Eval_Call (N : Node_Id) is
1666 Loc : constant Source_Ptr := Sloc (N);
1667 Typ : constant Entity_Id := Etype (N);
1671 if Nkind (N) = N_Function_Call
1672 and then No (Parameter_Associations (N))
1673 and then Is_Entity_Name (Name (N))
1674 and then Present (Alias (Entity (Name (N))))
1675 and then Is_Enumeration_Type (Base_Type (Typ))
1677 Lit := Ultimate_Alias (Entity (Name (N)));
1679 if Ekind (Lit) = E_Enumeration_Literal then
1680 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
1682 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
1684 Rewrite (N, New_Occurrence_Of (Lit, Loc));
1692 --------------------------
1693 -- Eval_Case_Expression --
1694 --------------------------
1696 -- Right now we do not attempt folding of any case expressions, and the
1697 -- language does not require it, so the only required processing is to
1698 -- do the check for all expressions appearing in the case expression.
1700 procedure Eval_Case_Expression (N : Node_Id) is
1704 Check_Non_Static_Context (Expression (N));
1706 Alt := First (Alternatives (N));
1707 while Present (Alt) loop
1708 Check_Non_Static_Context (Expression (Alt));
1711 end Eval_Case_Expression;
1713 ------------------------
1714 -- Eval_Concatenation --
1715 ------------------------
1717 -- Concatenation is a static function, so the result is static if both
1718 -- operands are static (RM 4.9(7), 4.9(21)).
1720 procedure Eval_Concatenation (N : Node_Id) is
1721 Left : constant Node_Id := Left_Opnd (N);
1722 Right : constant Node_Id := Right_Opnd (N);
1723 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
1728 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
1729 -- non-static context.
1731 if Ada_Version = Ada_83
1732 and then Comes_From_Source (N)
1734 Check_Non_Static_Context (Left);
1735 Check_Non_Static_Context (Right);
1739 -- If not foldable we are done. In principle concatenation that yields
1740 -- any string type is static (i.e. an array type of character types).
1741 -- However, character types can include enumeration literals, and
1742 -- concatenation in that case cannot be described by a literal, so we
1743 -- only consider the operation static if the result is an array of
1744 -- (a descendant of) a predefined character type.
1746 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1748 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
1749 Set_Is_Static_Expression (N, False);
1753 -- Compile time string concatenation
1755 -- ??? Note that operands that are aggregates can be marked as static,
1756 -- so we should attempt at a later stage to fold concatenations with
1760 Left_Str : constant Node_Id := Get_String_Val (Left);
1762 Right_Str : constant Node_Id := Get_String_Val (Right);
1763 Folded_Val : String_Id;
1766 -- Establish new string literal, and store left operand. We make
1767 -- sure to use the special Start_String that takes an operand if
1768 -- the left operand is a string literal. Since this is optimized
1769 -- in the case where that is the most recently created string
1770 -- literal, we ensure efficient time/space behavior for the
1771 -- case of a concatenation of a series of string literals.
1773 if Nkind (Left_Str) = N_String_Literal then
1774 Left_Len := String_Length (Strval (Left_Str));
1776 -- If the left operand is the empty string, and the right operand
1777 -- is a string literal (the case of "" & "..."), the result is the
1778 -- value of the right operand. This optimization is important when
1779 -- Is_Folded_In_Parser, to avoid copying an enormous right
1782 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
1783 Folded_Val := Strval (Right_Str);
1785 Start_String (Strval (Left_Str));
1790 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
1794 -- Now append the characters of the right operand, unless we
1795 -- optimized the "" & "..." case above.
1797 if Nkind (Right_Str) = N_String_Literal then
1798 if Left_Len /= 0 then
1799 Store_String_Chars (Strval (Right_Str));
1800 Folded_Val := End_String;
1803 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
1804 Folded_Val := End_String;
1807 Set_Is_Static_Expression (N, Stat);
1811 -- If left operand is the empty string, the result is the
1812 -- right operand, including its bounds if anomalous.
1815 and then Is_Array_Type (Etype (Right))
1816 and then Etype (Right) /= Any_String
1818 Set_Etype (N, Etype (Right));
1821 Fold_Str (N, Folded_Val, Static => True);
1824 end Eval_Concatenation;
1826 ---------------------------------
1827 -- Eval_Conditional_Expression --
1828 ---------------------------------
1830 -- We can fold to a static expression if the condition and both constituent
1831 -- expressions are static. Otherwise, the only required processing is to do
1832 -- the check for non-static context for the then and else expressions.
1834 procedure Eval_Conditional_Expression (N : Node_Id) is
1835 Condition : constant Node_Id := First (Expressions (N));
1836 Then_Expr : constant Node_Id := Next (Condition);
1837 Else_Expr : constant Node_Id := Next (Then_Expr);
1839 Non_Result : Node_Id;
1841 Rstat : constant Boolean :=
1842 Is_Static_Expression (Condition)
1844 Is_Static_Expression (Then_Expr)
1846 Is_Static_Expression (Else_Expr);
1849 -- If any operand is Any_Type, just propagate to result and do not try
1850 -- to fold, this prevents cascaded errors.
1852 if Etype (Condition) = Any_Type or else
1853 Etype (Then_Expr) = Any_Type or else
1854 Etype (Else_Expr) = Any_Type
1856 Set_Etype (N, Any_Type);
1857 Set_Is_Static_Expression (N, False);
1860 -- Static case where we can fold. Note that we don't try to fold cases
1861 -- where the condition is known at compile time, but the result is
1862 -- non-static. This avoids possible cases of infinite recursion where
1863 -- the expander puts in a redundant test and we remove it. Instead we
1864 -- deal with these cases in the expander.
1868 -- Select result operand
1870 if Is_True (Expr_Value (Condition)) then
1871 Result := Then_Expr;
1872 Non_Result := Else_Expr;
1874 Result := Else_Expr;
1875 Non_Result := Then_Expr;
1878 -- Note that it does not matter if the non-result operand raises a
1879 -- Constraint_Error, but if the result raises constraint error then
1880 -- we replace the node with a raise constraint error. This will
1881 -- properly propagate Raises_Constraint_Error since this flag is
1884 if Raises_Constraint_Error (Result) then
1885 Rewrite_In_Raise_CE (N, Result);
1886 Check_Non_Static_Context (Non_Result);
1888 -- Otherwise the result operand replaces the original node
1891 Rewrite (N, Relocate_Node (Result));
1894 -- Case of condition not known at compile time
1897 Check_Non_Static_Context (Condition);
1898 Check_Non_Static_Context (Then_Expr);
1899 Check_Non_Static_Context (Else_Expr);
1902 Set_Is_Static_Expression (N, Rstat);
1903 end Eval_Conditional_Expression;
1905 ----------------------
1906 -- Eval_Entity_Name --
1907 ----------------------
1909 -- This procedure is used for identifiers and expanded names other than
1910 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1911 -- static if they denote a static constant (RM 4.9(6)) or if the name
1912 -- denotes an enumeration literal (RM 4.9(22)).
1914 procedure Eval_Entity_Name (N : Node_Id) is
1915 Def_Id : constant Entity_Id := Entity (N);
1919 -- Enumeration literals are always considered to be constants
1920 -- and cannot raise constraint error (RM 4.9(22)).
1922 if Ekind (Def_Id) = E_Enumeration_Literal then
1923 Set_Is_Static_Expression (N);
1926 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1927 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1928 -- it does not violate 10.2.1(8) here, since this is not a variable.
1930 elsif Ekind (Def_Id) = E_Constant then
1932 -- Deferred constants must always be treated as nonstatic
1933 -- outside the scope of their full view.
1935 if Present (Full_View (Def_Id))
1936 and then not In_Open_Scopes (Scope (Def_Id))
1940 Val := Constant_Value (Def_Id);
1943 if Present (Val) then
1944 Set_Is_Static_Expression
1945 (N, Is_Static_Expression (Val)
1946 and then Is_Static_Subtype (Etype (Def_Id)));
1947 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1949 if not Is_Static_Expression (N)
1950 and then not Is_Generic_Type (Etype (N))
1952 Validate_Static_Object_Name (N);
1959 -- Fall through if the name is not static
1961 Validate_Static_Object_Name (N);
1962 end Eval_Entity_Name;
1964 ----------------------------
1965 -- Eval_Indexed_Component --
1966 ----------------------------
1968 -- Indexed components are never static, so we need to perform the check
1969 -- for non-static context on the index values. Then, we check if the
1970 -- value can be obtained at compile time, even though it is non-static.
1972 procedure Eval_Indexed_Component (N : Node_Id) is
1976 -- Check for non-static context on index values
1978 Expr := First (Expressions (N));
1979 while Present (Expr) loop
1980 Check_Non_Static_Context (Expr);
1984 -- If the indexed component appears in an object renaming declaration
1985 -- then we do not want to try to evaluate it, since in this case we
1986 -- need the identity of the array element.
1988 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
1991 -- Similarly if the indexed component appears as the prefix of an
1992 -- attribute we don't want to evaluate it, because at least for
1993 -- some cases of attributes we need the identify (e.g. Access, Size)
1995 elsif Nkind (Parent (N)) = N_Attribute_Reference then
1999 -- Note: there are other cases, such as the left side of an assignment,
2000 -- or an OUT parameter for a call, where the replacement results in the
2001 -- illegal use of a constant, But these cases are illegal in the first
2002 -- place, so the replacement, though silly, is harmless.
2004 -- Now see if this is a constant array reference
2006 if List_Length (Expressions (N)) = 1
2007 and then Is_Entity_Name (Prefix (N))
2008 and then Ekind (Entity (Prefix (N))) = E_Constant
2009 and then Present (Constant_Value (Entity (Prefix (N))))
2012 Loc : constant Source_Ptr := Sloc (N);
2013 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2014 Sub : constant Node_Id := First (Expressions (N));
2020 -- Linear one's origin subscript value for array reference
2023 -- Lower bound of the first array index
2026 -- Value from constant array
2029 Atyp := Etype (Arr);
2031 if Is_Access_Type (Atyp) then
2032 Atyp := Designated_Type (Atyp);
2035 -- If we have an array type (we should have but perhaps there are
2036 -- error cases where this is not the case), then see if we can do
2037 -- a constant evaluation of the array reference.
2039 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2040 if Ekind (Atyp) = E_String_Literal_Subtype then
2041 Lbd := String_Literal_Low_Bound (Atyp);
2043 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2046 if Compile_Time_Known_Value (Sub)
2047 and then Nkind (Arr) = N_Aggregate
2048 and then Compile_Time_Known_Value (Lbd)
2049 and then Is_Discrete_Type (Component_Type (Atyp))
2051 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2053 if List_Length (Expressions (Arr)) >= Lin then
2054 Elm := Pick (Expressions (Arr), Lin);
2056 -- If the resulting expression is compile time known,
2057 -- then we can rewrite the indexed component with this
2058 -- value, being sure to mark the result as non-static.
2059 -- We also reset the Sloc, in case this generates an
2060 -- error later on (e.g. 136'Access).
2062 if Compile_Time_Known_Value (Elm) then
2063 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2064 Set_Is_Static_Expression (N, False);
2069 -- We can also constant-fold if the prefix is a string literal.
2070 -- This will be useful in an instantiation or an inlining.
2072 elsif Compile_Time_Known_Value (Sub)
2073 and then Nkind (Arr) = N_String_Literal
2074 and then Compile_Time_Known_Value (Lbd)
2075 and then Expr_Value (Lbd) = 1
2076 and then Expr_Value (Sub) <=
2077 String_Literal_Length (Etype (Arr))
2080 C : constant Char_Code :=
2081 Get_String_Char (Strval (Arr),
2082 UI_To_Int (Expr_Value (Sub)));
2084 Set_Character_Literal_Name (C);
2087 Make_Character_Literal (Loc,
2089 Char_Literal_Value => UI_From_CC (C));
2090 Set_Etype (Elm, Component_Type (Atyp));
2091 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2092 Set_Is_Static_Expression (N, False);
2098 end Eval_Indexed_Component;
2100 --------------------------
2101 -- Eval_Integer_Literal --
2102 --------------------------
2104 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2105 -- as static by the analyzer. The reason we did it that early is to allow
2106 -- the possibility of turning off the Is_Static_Expression flag after
2107 -- analysis, but before resolution, when integer literals are generated in
2108 -- the expander that do not correspond to static expressions.
2110 procedure Eval_Integer_Literal (N : Node_Id) is
2111 T : constant Entity_Id := Etype (N);
2113 function In_Any_Integer_Context return Boolean;
2114 -- If the literal is resolved with a specific type in a context where
2115 -- the expected type is Any_Integer, there are no range checks on the
2116 -- literal. By the time the literal is evaluated, it carries the type
2117 -- imposed by the enclosing expression, and we must recover the context
2118 -- to determine that Any_Integer is meant.
2120 ----------------------------
2121 -- In_Any_Integer_Context --
2122 ----------------------------
2124 function In_Any_Integer_Context return Boolean is
2125 Par : constant Node_Id := Parent (N);
2126 K : constant Node_Kind := Nkind (Par);
2129 -- Any_Integer also appears in digits specifications for real types,
2130 -- but those have bounds smaller that those of any integer base type,
2131 -- so we can safely ignore these cases.
2133 return K = N_Number_Declaration
2134 or else K = N_Attribute_Reference
2135 or else K = N_Attribute_Definition_Clause
2136 or else K = N_Modular_Type_Definition
2137 or else K = N_Signed_Integer_Type_Definition;
2138 end In_Any_Integer_Context;
2140 -- Start of processing for Eval_Integer_Literal
2144 -- If the literal appears in a non-expression context, then it is
2145 -- certainly appearing in a non-static context, so check it. This is
2146 -- actually a redundant check, since Check_Non_Static_Context would
2147 -- check it, but it seems worth while avoiding the call.
2149 if Nkind (Parent (N)) not in N_Subexpr
2150 and then not In_Any_Integer_Context
2152 Check_Non_Static_Context (N);
2155 -- Modular integer literals must be in their base range
2157 if Is_Modular_Integer_Type (T)
2158 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2162 end Eval_Integer_Literal;
2164 ---------------------
2165 -- Eval_Logical_Op --
2166 ---------------------
2168 -- Logical operations are static functions, so the result is potentially
2169 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2171 procedure Eval_Logical_Op (N : Node_Id) is
2172 Left : constant Node_Id := Left_Opnd (N);
2173 Right : constant Node_Id := Right_Opnd (N);
2178 -- If not foldable we are done
2180 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2186 -- Compile time evaluation of logical operation
2189 Left_Int : constant Uint := Expr_Value (Left);
2190 Right_Int : constant Uint := Expr_Value (Right);
2193 -- VMS includes bitwise operations on signed types
2195 if Is_Modular_Integer_Type (Etype (N))
2196 or else Is_VMS_Operator (Entity (N))
2199 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2200 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2203 To_Bits (Left_Int, Left_Bits);
2204 To_Bits (Right_Int, Right_Bits);
2206 -- Note: should really be able to use array ops instead of
2207 -- these loops, but they weren't working at the time ???
2209 if Nkind (N) = N_Op_And then
2210 for J in Left_Bits'Range loop
2211 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2214 elsif Nkind (N) = N_Op_Or then
2215 for J in Left_Bits'Range loop
2216 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2220 pragma Assert (Nkind (N) = N_Op_Xor);
2222 for J in Left_Bits'Range loop
2223 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2227 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2231 pragma Assert (Is_Boolean_Type (Etype (N)));
2233 if Nkind (N) = N_Op_And then
2235 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2237 elsif Nkind (N) = N_Op_Or then
2239 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2242 pragma Assert (Nkind (N) = N_Op_Xor);
2244 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2248 end Eval_Logical_Op;
2250 ------------------------
2251 -- Eval_Membership_Op --
2252 ------------------------
2254 -- A membership test is potentially static if the expression is static, and
2255 -- the range is a potentially static range, or is a subtype mark denoting a
2256 -- static subtype (RM 4.9(12)).
2258 procedure Eval_Membership_Op (N : Node_Id) is
2259 Left : constant Node_Id := Left_Opnd (N);
2260 Right : constant Node_Id := Right_Opnd (N);
2269 -- Ignore if error in either operand, except to make sure that Any_Type
2270 -- is properly propagated to avoid junk cascaded errors.
2272 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2273 Set_Etype (N, Any_Type);
2277 -- Case of right operand is a subtype name
2279 if Is_Entity_Name (Right) then
2280 Def_Id := Entity (Right);
2282 if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
2283 and then Is_OK_Static_Subtype (Def_Id)
2285 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2287 if not Fold or else not Stat then
2291 Check_Non_Static_Context (Left);
2295 -- For string membership tests we will check the length further on
2297 if not Is_String_Type (Def_Id) then
2298 Lo := Type_Low_Bound (Def_Id);
2299 Hi := Type_High_Bound (Def_Id);
2306 -- Case of right operand is a range
2309 if Is_Static_Range (Right) then
2310 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2312 if not Fold or else not Stat then
2315 -- If one bound of range raises CE, then don't try to fold
2317 elsif not Is_OK_Static_Range (Right) then
2318 Check_Non_Static_Context (Left);
2323 Check_Non_Static_Context (Left);
2327 -- Here we know range is an OK static range
2329 Lo := Low_Bound (Right);
2330 Hi := High_Bound (Right);
2333 -- For strings we check that the length of the string expression is
2334 -- compatible with the string subtype if the subtype is constrained,
2335 -- or if unconstrained then the test is always true.
2337 if Is_String_Type (Etype (Right)) then
2338 if not Is_Constrained (Etype (Right)) then
2343 Typlen : constant Uint := String_Type_Len (Etype (Right));
2344 Strlen : constant Uint :=
2346 (String_Length (Strval (Get_String_Val (Left))));
2348 Result := (Typlen = Strlen);
2352 -- Fold the membership test. We know we have a static range and Lo and
2353 -- Hi are set to the expressions for the end points of this range.
2355 elsif Is_Real_Type (Etype (Right)) then
2357 Leftval : constant Ureal := Expr_Value_R (Left);
2360 Result := Expr_Value_R (Lo) <= Leftval
2361 and then Leftval <= Expr_Value_R (Hi);
2366 Leftval : constant Uint := Expr_Value (Left);
2369 Result := Expr_Value (Lo) <= Leftval
2370 and then Leftval <= Expr_Value (Hi);
2374 if Nkind (N) = N_Not_In then
2375 Result := not Result;
2378 Fold_Uint (N, Test (Result), True);
2380 Warn_On_Known_Condition (N);
2381 end Eval_Membership_Op;
2383 ------------------------
2384 -- Eval_Named_Integer --
2385 ------------------------
2387 procedure Eval_Named_Integer (N : Node_Id) is
2390 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2391 end Eval_Named_Integer;
2393 ---------------------
2394 -- Eval_Named_Real --
2395 ---------------------
2397 procedure Eval_Named_Real (N : Node_Id) is
2400 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2401 end Eval_Named_Real;
2407 -- Exponentiation is a static functions, so the result is potentially
2408 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2410 procedure Eval_Op_Expon (N : Node_Id) is
2411 Left : constant Node_Id := Left_Opnd (N);
2412 Right : constant Node_Id := Right_Opnd (N);
2417 -- If not foldable we are done
2419 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2425 -- Fold exponentiation operation
2428 Right_Int : constant Uint := Expr_Value (Right);
2433 if Is_Integer_Type (Etype (Left)) then
2435 Left_Int : constant Uint := Expr_Value (Left);
2439 -- Exponentiation of an integer raises Constraint_Error for a
2440 -- negative exponent (RM 4.5.6).
2442 if Right_Int < 0 then
2443 Apply_Compile_Time_Constraint_Error
2444 (N, "integer exponent negative",
2445 CE_Range_Check_Failed,
2450 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2451 Result := Left_Int ** Right_Int;
2456 if Is_Modular_Integer_Type (Etype (N)) then
2457 Result := Result mod Modulus (Etype (N));
2460 Fold_Uint (N, Result, Stat);
2468 Left_Real : constant Ureal := Expr_Value_R (Left);
2471 -- Cannot have a zero base with a negative exponent
2473 if UR_Is_Zero (Left_Real) then
2475 if Right_Int < 0 then
2476 Apply_Compile_Time_Constraint_Error
2477 (N, "zero ** negative integer",
2478 CE_Range_Check_Failed,
2482 Fold_Ureal (N, Ureal_0, Stat);
2486 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2497 -- The not operation is a static functions, so the result is potentially
2498 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2500 procedure Eval_Op_Not (N : Node_Id) is
2501 Right : constant Node_Id := Right_Opnd (N);
2506 -- If not foldable we are done
2508 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2514 -- Fold not operation
2517 Rint : constant Uint := Expr_Value (Right);
2518 Typ : constant Entity_Id := Etype (N);
2521 -- Negation is equivalent to subtracting from the modulus minus one.
2522 -- For a binary modulus this is equivalent to the ones-complement of
2523 -- the original value. For non-binary modulus this is an arbitrary
2524 -- but consistent definition.
2526 if Is_Modular_Integer_Type (Typ) then
2527 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2530 pragma Assert (Is_Boolean_Type (Typ));
2531 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2534 Set_Is_Static_Expression (N, Stat);
2538 -------------------------------
2539 -- Eval_Qualified_Expression --
2540 -------------------------------
2542 -- A qualified expression is potentially static if its subtype mark denotes
2543 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2545 procedure Eval_Qualified_Expression (N : Node_Id) is
2546 Operand : constant Node_Id := Expression (N);
2547 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2554 -- Can only fold if target is string or scalar and subtype is static.
2555 -- Also, do not fold if our parent is an allocator (this is because the
2556 -- qualified expression is really part of the syntactic structure of an
2557 -- allocator, and we do not want to end up with something that
2558 -- corresponds to "new 1" where the 1 is the result of folding a
2559 -- qualified expression).
2561 if not Is_Static_Subtype (Target_Type)
2562 or else Nkind (Parent (N)) = N_Allocator
2564 Check_Non_Static_Context (Operand);
2566 -- If operand is known to raise constraint_error, set the flag on the
2567 -- expression so it does not get optimized away.
2569 if Nkind (Operand) = N_Raise_Constraint_Error then
2570 Set_Raises_Constraint_Error (N);
2576 -- If not foldable we are done
2578 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2583 -- Don't try fold if target type has constraint error bounds
2585 elsif not Is_OK_Static_Subtype (Target_Type) then
2586 Set_Raises_Constraint_Error (N);
2590 -- Here we will fold, save Print_In_Hex indication
2592 Hex := Nkind (Operand) = N_Integer_Literal
2593 and then Print_In_Hex (Operand);
2595 -- Fold the result of qualification
2597 if Is_Discrete_Type (Target_Type) then
2598 Fold_Uint (N, Expr_Value (Operand), Stat);
2600 -- Preserve Print_In_Hex indication
2602 if Hex and then Nkind (N) = N_Integer_Literal then
2603 Set_Print_In_Hex (N);
2606 elsif Is_Real_Type (Target_Type) then
2607 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
2610 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
2613 Set_Is_Static_Expression (N, False);
2615 Check_String_Literal_Length (N, Target_Type);
2621 -- The expression may be foldable but not static
2623 Set_Is_Static_Expression (N, Stat);
2625 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
2628 end Eval_Qualified_Expression;
2630 -----------------------
2631 -- Eval_Real_Literal --
2632 -----------------------
2634 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2635 -- as static by the analyzer. The reason we did it that early is to allow
2636 -- the possibility of turning off the Is_Static_Expression flag after
2637 -- analysis, but before resolution, when integer literals are generated
2638 -- in the expander that do not correspond to static expressions.
2640 procedure Eval_Real_Literal (N : Node_Id) is
2641 PK : constant Node_Kind := Nkind (Parent (N));
2644 -- If the literal appears in a non-expression context and not as part of
2645 -- a number declaration, then it is appearing in a non-static context,
2648 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
2649 Check_Non_Static_Context (N);
2651 end Eval_Real_Literal;
2653 ------------------------
2654 -- Eval_Relational_Op --
2655 ------------------------
2657 -- Relational operations are static functions, so the result is static if
2658 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
2659 -- the result is never static, even if the operands are.
2661 procedure Eval_Relational_Op (N : Node_Id) is
2662 Left : constant Node_Id := Left_Opnd (N);
2663 Right : constant Node_Id := Right_Opnd (N);
2664 Typ : constant Entity_Id := Etype (Left);
2665 Otype : Entity_Id := Empty;
2671 -- One special case to deal with first. If we can tell that the result
2672 -- will be false because the lengths of one or more index subtypes are
2673 -- compile time known and different, then we can replace the entire
2674 -- result by False. We only do this for one dimensional arrays, because
2675 -- the case of multi-dimensional arrays is rare and too much trouble! If
2676 -- one of the operands is an illegal aggregate, its type might still be
2677 -- an arbitrary composite type, so nothing to do.
2679 if Is_Array_Type (Typ)
2680 and then Typ /= Any_Composite
2681 and then Number_Dimensions (Typ) = 1
2682 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
2684 if Raises_Constraint_Error (Left)
2685 or else Raises_Constraint_Error (Right)
2690 -- OK, we have the case where we may be able to do this fold
2692 Length_Mismatch : declare
2693 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
2694 -- If Op is an expression for a constrained array with a known at
2695 -- compile time length, then Len is set to this (non-negative
2696 -- length). Otherwise Len is set to minus 1.
2698 -----------------------
2699 -- Get_Static_Length --
2700 -----------------------
2702 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2706 -- First easy case string literal
2708 if Nkind (Op) = N_String_Literal then
2709 Len := UI_From_Int (String_Length (Strval (Op)));
2713 -- Second easy case, not constrained subtype, so no length
2715 if not Is_Constrained (Etype (Op)) then
2716 Len := Uint_Minus_1;
2722 T := Etype (First_Index (Etype (Op)));
2724 -- The simple case, both bounds are known at compile time
2726 if Is_Discrete_Type (T)
2728 Compile_Time_Known_Value (Type_Low_Bound (T))
2730 Compile_Time_Known_Value (Type_High_Bound (T))
2732 Len := UI_Max (Uint_0,
2733 Expr_Value (Type_High_Bound (T)) -
2734 Expr_Value (Type_Low_Bound (T)) + 1);
2738 -- A more complex case, where the bounds are of the form
2739 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2740 -- either A'First or A'Last (with A an entity name), or X is an
2741 -- entity name, and the two X's are the same and K1 and K2 are
2742 -- known at compile time, in this case, the length can also be
2743 -- computed at compile time, even though the bounds are not
2744 -- known. A common case of this is e.g. (X'First .. X'First+5).
2746 Extract_Length : declare
2747 procedure Decompose_Expr
2749 Ent : out Entity_Id;
2750 Kind : out Character;
2752 -- Given an expression, see if is of the form above,
2753 -- X [+/- K]. If so Ent is set to the entity in X,
2754 -- Kind is 'F','L','E' for 'First/'Last/simple entity,
2755 -- and Cons is the value of K. If the expression is
2756 -- not of the required form, Ent is set to Empty.
2758 --------------------
2759 -- Decompose_Expr --
2760 --------------------
2762 procedure Decompose_Expr
2764 Ent : out Entity_Id;
2765 Kind : out Character;
2771 if Nkind (Expr) = N_Op_Add
2772 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2774 Exp := Left_Opnd (Expr);
2775 Cons := Expr_Value (Right_Opnd (Expr));
2777 elsif Nkind (Expr) = N_Op_Subtract
2778 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2780 Exp := Left_Opnd (Expr);
2781 Cons := -Expr_Value (Right_Opnd (Expr));
2783 -- If the bound is a constant created to remove side
2784 -- effects, recover original expression to see if it has
2785 -- one of the recognizable forms.
2787 elsif Nkind (Expr) = N_Identifier
2788 and then not Comes_From_Source (Entity (Expr))
2789 and then Ekind (Entity (Expr)) = E_Constant
2791 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
2793 Exp := Expression (Parent (Entity (Expr)));
2794 Decompose_Expr (Exp, Ent, Kind, Cons);
2796 -- If original expression includes an entity, create a
2797 -- reference to it for use below.
2799 if Present (Ent) then
2800 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
2808 -- At this stage Exp is set to the potential X
2810 if Nkind (Exp) = N_Attribute_Reference then
2811 if Attribute_Name (Exp) = Name_First then
2814 elsif Attribute_Name (Exp) = Name_Last then
2822 Exp := Prefix (Exp);
2828 if Is_Entity_Name (Exp)
2829 and then Present (Entity (Exp))
2831 Ent := Entity (Exp);
2839 Ent1, Ent2 : Entity_Id;
2840 Kind1, Kind2 : Character;
2841 Cons1, Cons2 : Uint;
2843 -- Start of processing for Extract_Length
2847 (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
2849 (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
2852 and then Kind1 = Kind2
2853 and then Ent1 = Ent2
2855 Len := Cons2 - Cons1 + 1;
2857 Len := Uint_Minus_1;
2860 end Get_Static_Length;
2867 -- Start of processing for Length_Mismatch
2870 Get_Static_Length (Left, Len_L);
2871 Get_Static_Length (Right, Len_R);
2873 if Len_L /= Uint_Minus_1
2874 and then Len_R /= Uint_Minus_1
2875 and then Len_L /= Len_R
2877 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2878 Warn_On_Known_Condition (N);
2881 end Length_Mismatch;
2884 -- Test for expression being foldable
2886 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2888 -- Only comparisons of scalars can give static results. In particular,
2889 -- comparisons of strings never yield a static result, even if both
2890 -- operands are static strings.
2892 if not Is_Scalar_Type (Typ) then
2894 Set_Is_Static_Expression (N, False);
2897 -- For operators on universal numeric types called as functions with
2898 -- an explicit scope, determine appropriate specific numeric type, and
2899 -- diagnose possible ambiguity.
2901 if Is_Universal_Numeric_Type (Etype (Left))
2903 Is_Universal_Numeric_Type (Etype (Right))
2905 Otype := Find_Universal_Operator_Type (N);
2908 -- For static real type expressions, we cannot use Compile_Time_Compare
2909 -- since it worries about run-time results which are not exact.
2911 if Stat and then Is_Real_Type (Typ) then
2913 Left_Real : constant Ureal := Expr_Value_R (Left);
2914 Right_Real : constant Ureal := Expr_Value_R (Right);
2918 when N_Op_Eq => Result := (Left_Real = Right_Real);
2919 when N_Op_Ne => Result := (Left_Real /= Right_Real);
2920 when N_Op_Lt => Result := (Left_Real < Right_Real);
2921 when N_Op_Le => Result := (Left_Real <= Right_Real);
2922 when N_Op_Gt => Result := (Left_Real > Right_Real);
2923 when N_Op_Ge => Result := (Left_Real >= Right_Real);
2926 raise Program_Error;
2929 Fold_Uint (N, Test (Result), True);
2932 -- For all other cases, we use Compile_Time_Compare to do the compare
2936 CR : constant Compare_Result :=
2937 Compile_Time_Compare (Left, Right, Assume_Valid => False);
2940 if CR = Unknown then
2948 elsif CR = NE or else CR = GT or else CR = LT then
2955 if CR = NE or else CR = GT or else CR = LT then
2966 elsif CR = EQ or else CR = GT or else CR = GE then
2973 if CR = LT or else CR = EQ or else CR = LE then
2984 elsif CR = EQ or else CR = LT or else CR = LE then
2991 if CR = GT or else CR = EQ or else CR = GE then
3000 raise Program_Error;
3004 Fold_Uint (N, Test (Result), Stat);
3007 -- For the case of a folded relational operator on a specific numeric
3008 -- type, freeze operand type now.
3010 if Present (Otype) then
3011 Freeze_Before (N, Otype);
3014 Warn_On_Known_Condition (N);
3015 end Eval_Relational_Op;
3021 -- Shift operations are intrinsic operations that can never be static, so
3022 -- the only processing required is to perform the required check for a non
3023 -- static context for the two operands.
3025 -- Actually we could do some compile time evaluation here some time ???
3027 procedure Eval_Shift (N : Node_Id) is
3029 Check_Non_Static_Context (Left_Opnd (N));
3030 Check_Non_Static_Context (Right_Opnd (N));
3033 ------------------------
3034 -- Eval_Short_Circuit --
3035 ------------------------
3037 -- A short circuit operation is potentially static if both operands are
3038 -- potentially static (RM 4.9 (13)).
3040 procedure Eval_Short_Circuit (N : Node_Id) is
3041 Kind : constant Node_Kind := Nkind (N);
3042 Left : constant Node_Id := Left_Opnd (N);
3043 Right : constant Node_Id := Right_Opnd (N);
3046 Rstat : constant Boolean :=
3047 Is_Static_Expression (Left)
3049 Is_Static_Expression (Right);
3052 -- Short circuit operations are never static in Ada 83
3054 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3055 Check_Non_Static_Context (Left);
3056 Check_Non_Static_Context (Right);
3060 -- Now look at the operands, we can't quite use the normal call to
3061 -- Test_Expression_Is_Foldable here because short circuit operations
3062 -- are a special case, they can still be foldable, even if the right
3063 -- operand raises constraint error.
3065 -- If either operand is Any_Type, just propagate to result and do not
3066 -- try to fold, this prevents cascaded errors.
3068 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3069 Set_Etype (N, Any_Type);
3072 -- If left operand raises constraint error, then replace node N with
3073 -- the raise constraint error node, and we are obviously not foldable.
3074 -- Is_Static_Expression is set from the two operands in the normal way,
3075 -- and we check the right operand if it is in a non-static context.
3077 elsif Raises_Constraint_Error (Left) then
3079 Check_Non_Static_Context (Right);
3082 Rewrite_In_Raise_CE (N, Left);
3083 Set_Is_Static_Expression (N, Rstat);
3086 -- If the result is not static, then we won't in any case fold
3088 elsif not Rstat then
3089 Check_Non_Static_Context (Left);
3090 Check_Non_Static_Context (Right);
3094 -- Here the result is static, note that, unlike the normal processing
3095 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3096 -- the right operand raises constraint error, that's because it is not
3097 -- significant if the left operand is decisive.
3099 Set_Is_Static_Expression (N);
3101 -- It does not matter if the right operand raises constraint error if
3102 -- it will not be evaluated. So deal specially with the cases where
3103 -- the right operand is not evaluated. Note that we will fold these
3104 -- cases even if the right operand is non-static, which is fine, but
3105 -- of course in these cases the result is not potentially static.
3107 Left_Int := Expr_Value (Left);
3109 if (Kind = N_And_Then and then Is_False (Left_Int))
3111 (Kind = N_Or_Else and then Is_True (Left_Int))
3113 Fold_Uint (N, Left_Int, Rstat);
3117 -- If first operand not decisive, then it does matter if the right
3118 -- operand raises constraint error, since it will be evaluated, so
3119 -- we simply replace the node with the right operand. Note that this
3120 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3121 -- (both are set to True in Right).
3123 if Raises_Constraint_Error (Right) then
3124 Rewrite_In_Raise_CE (N, Right);
3125 Check_Non_Static_Context (Left);
3129 -- Otherwise the result depends on the right operand
3131 Fold_Uint (N, Expr_Value (Right), Rstat);
3133 end Eval_Short_Circuit;
3139 -- Slices can never be static, so the only processing required is to check
3140 -- for non-static context if an explicit range is given.
3142 procedure Eval_Slice (N : Node_Id) is
3143 Drange : constant Node_Id := Discrete_Range (N);
3145 if Nkind (Drange) = N_Range then
3146 Check_Non_Static_Context (Low_Bound (Drange));
3147 Check_Non_Static_Context (High_Bound (Drange));
3150 -- A slice of the form A (subtype), when the subtype is the index of
3151 -- the type of A, is redundant, the slice can be replaced with A, and
3152 -- this is worth a warning.
3154 if Is_Entity_Name (Prefix (N)) then
3156 E : constant Entity_Id := Entity (Prefix (N));
3157 T : constant Entity_Id := Etype (E);
3159 if Ekind (E) = E_Constant
3160 and then Is_Array_Type (T)
3161 and then Is_Entity_Name (Drange)
3163 if Is_Entity_Name (Original_Node (First_Index (T)))
3164 and then Entity (Original_Node (First_Index (T)))
3167 if Warn_On_Redundant_Constructs then
3168 Error_Msg_N ("redundant slice denotes whole array?", N);
3171 -- The following might be a useful optimization????
3173 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3180 -------------------------
3181 -- Eval_String_Literal --
3182 -------------------------
3184 procedure Eval_String_Literal (N : Node_Id) is
3185 Typ : constant Entity_Id := Etype (N);
3186 Bas : constant Entity_Id := Base_Type (Typ);
3192 -- Nothing to do if error type (handles cases like default expressions
3193 -- or generics where we have not yet fully resolved the type).
3195 if Bas = Any_Type or else Bas = Any_String then
3199 -- String literals are static if the subtype is static (RM 4.9(2)), so
3200 -- reset the static expression flag (it was set unconditionally in
3201 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3202 -- the subtype is static by looking at the lower bound.
3204 if Ekind (Typ) = E_String_Literal_Subtype then
3205 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3206 Set_Is_Static_Expression (N, False);
3210 -- Here if Etype of string literal is normal Etype (not yet possible,
3211 -- but may be possible in future).
3213 elsif not Is_OK_Static_Expression
3214 (Type_Low_Bound (Etype (First_Index (Typ))))
3216 Set_Is_Static_Expression (N, False);
3220 -- If original node was a type conversion, then result if non-static
3222 if Nkind (Original_Node (N)) = N_Type_Conversion then
3223 Set_Is_Static_Expression (N, False);
3227 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3228 -- if its bounds are outside the index base type and this index type is
3229 -- static. This can happen in only two ways. Either the string literal
3230 -- is too long, or it is null, and the lower bound is type'First. In
3231 -- either case it is the upper bound that is out of range of the index
3234 if Ada_Version >= Ada_95 then
3235 if Root_Type (Bas) = Standard_String
3237 Root_Type (Bas) = Standard_Wide_String
3239 Xtp := Standard_Positive;
3241 Xtp := Etype (First_Index (Bas));
3244 if Ekind (Typ) = E_String_Literal_Subtype then
3245 Lo := String_Literal_Low_Bound (Typ);
3247 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3250 Len := String_Length (Strval (N));
3252 if UI_From_Int (Len) > String_Type_Len (Bas) then
3253 Apply_Compile_Time_Constraint_Error
3254 (N, "string literal too long for}", CE_Length_Check_Failed,
3256 Typ => First_Subtype (Bas));
3259 and then not Is_Generic_Type (Xtp)
3261 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3263 Apply_Compile_Time_Constraint_Error
3264 (N, "null string literal not allowed for}",
3265 CE_Length_Check_Failed,
3267 Typ => First_Subtype (Bas));
3270 end Eval_String_Literal;
3272 --------------------------
3273 -- Eval_Type_Conversion --
3274 --------------------------
3276 -- A type conversion is potentially static if its subtype mark is for a
3277 -- static scalar subtype, and its operand expression is potentially static
3280 procedure Eval_Type_Conversion (N : Node_Id) is
3281 Operand : constant Node_Id := Expression (N);
3282 Source_Type : constant Entity_Id := Etype (Operand);
3283 Target_Type : constant Entity_Id := Etype (N);
3288 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3289 -- Returns true if type T is an integer type, or if it is a fixed-point
3290 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3291 -- on the conversion node).
3293 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3294 -- Returns true if type T is a floating-point type, or if it is a
3295 -- fixed-point type that is not to be treated as an integer (i.e. the
3296 -- flag Conversion_OK is not set on the conversion node).
3298 ------------------------------
3299 -- To_Be_Treated_As_Integer --
3300 ------------------------------
3302 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3306 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3307 end To_Be_Treated_As_Integer;
3309 ---------------------------
3310 -- To_Be_Treated_As_Real --
3311 ---------------------------
3313 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3316 Is_Floating_Point_Type (T)
3317 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3318 end To_Be_Treated_As_Real;
3320 -- Start of processing for Eval_Type_Conversion
3323 -- Cannot fold if target type is non-static or if semantic error
3325 if not Is_Static_Subtype (Target_Type) then
3326 Check_Non_Static_Context (Operand);
3329 elsif Error_Posted (N) then
3333 -- If not foldable we are done
3335 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3340 -- Don't try fold if target type has constraint error bounds
3342 elsif not Is_OK_Static_Subtype (Target_Type) then
3343 Set_Raises_Constraint_Error (N);
3347 -- Remaining processing depends on operand types. Note that in the
3348 -- following type test, fixed-point counts as real unless the flag
3349 -- Conversion_OK is set, in which case it counts as integer.
3351 -- Fold conversion, case of string type. The result is not static
3353 if Is_String_Type (Target_Type) then
3354 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3358 -- Fold conversion, case of integer target type
3360 elsif To_Be_Treated_As_Integer (Target_Type) then
3365 -- Integer to integer conversion
3367 if To_Be_Treated_As_Integer (Source_Type) then
3368 Result := Expr_Value (Operand);
3370 -- Real to integer conversion
3373 Result := UR_To_Uint (Expr_Value_R (Operand));
3376 -- If fixed-point type (Conversion_OK must be set), then the
3377 -- result is logically an integer, but we must replace the
3378 -- conversion with the corresponding real literal, since the
3379 -- type from a semantic point of view is still fixed-point.
3381 if Is_Fixed_Point_Type (Target_Type) then
3383 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3385 -- Otherwise result is integer literal
3388 Fold_Uint (N, Result, Stat);
3392 -- Fold conversion, case of real target type
3394 elsif To_Be_Treated_As_Real (Target_Type) then
3399 if To_Be_Treated_As_Real (Source_Type) then
3400 Result := Expr_Value_R (Operand);
3402 Result := UR_From_Uint (Expr_Value (Operand));
3405 Fold_Ureal (N, Result, Stat);
3408 -- Enumeration types
3411 Fold_Uint (N, Expr_Value (Operand), Stat);
3414 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3418 end Eval_Type_Conversion;
3424 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3425 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3427 procedure Eval_Unary_Op (N : Node_Id) is
3428 Right : constant Node_Id := Right_Opnd (N);
3429 Otype : Entity_Id := Empty;
3434 -- If not foldable we are done
3436 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3442 if Etype (Right) = Universal_Integer
3444 Etype (Right) = Universal_Real
3446 Otype := Find_Universal_Operator_Type (N);
3449 -- Fold for integer case
3451 if Is_Integer_Type (Etype (N)) then
3453 Rint : constant Uint := Expr_Value (Right);
3457 -- In the case of modular unary plus and abs there is no need
3458 -- to adjust the result of the operation since if the original
3459 -- operand was in bounds the result will be in the bounds of the
3460 -- modular type. However, in the case of modular unary minus the
3461 -- result may go out of the bounds of the modular type and needs
3464 if Nkind (N) = N_Op_Plus then
3467 elsif Nkind (N) = N_Op_Minus then
3468 if Is_Modular_Integer_Type (Etype (N)) then
3469 Result := (-Rint) mod Modulus (Etype (N));
3475 pragma Assert (Nkind (N) = N_Op_Abs);
3479 Fold_Uint (N, Result, Stat);
3482 -- Fold for real case
3484 elsif Is_Real_Type (Etype (N)) then
3486 Rreal : constant Ureal := Expr_Value_R (Right);
3490 if Nkind (N) = N_Op_Plus then
3493 elsif Nkind (N) = N_Op_Minus then
3494 Result := UR_Negate (Rreal);
3497 pragma Assert (Nkind (N) = N_Op_Abs);
3498 Result := abs Rreal;
3501 Fold_Ureal (N, Result, Stat);
3505 -- If the operator was resolved to a specific type, make sure that type
3506 -- is frozen even if the expression is folded into a literal (which has
3507 -- a universal type).
3509 if Present (Otype) then
3510 Freeze_Before (N, Otype);
3514 -------------------------------
3515 -- Eval_Unchecked_Conversion --
3516 -------------------------------
3518 -- Unchecked conversions can never be static, so the only required
3519 -- processing is to check for a non-static context for the operand.
3521 procedure Eval_Unchecked_Conversion (N : Node_Id) is
3523 Check_Non_Static_Context (Expression (N));
3524 end Eval_Unchecked_Conversion;
3526 --------------------
3527 -- Expr_Rep_Value --
3528 --------------------
3530 function Expr_Rep_Value (N : Node_Id) return Uint is
3531 Kind : constant Node_Kind := Nkind (N);
3535 if Is_Entity_Name (N) then
3538 -- An enumeration literal that was either in the source or created
3539 -- as a result of static evaluation.
3541 if Ekind (Ent) = E_Enumeration_Literal then
3542 return Enumeration_Rep (Ent);
3544 -- A user defined static constant
3547 pragma Assert (Ekind (Ent) = E_Constant);
3548 return Expr_Rep_Value (Constant_Value (Ent));
3551 -- An integer literal that was either in the source or created as a
3552 -- result of static evaluation.
3554 elsif Kind = N_Integer_Literal then
3557 -- A real literal for a fixed-point type. This must be the fixed-point
3558 -- case, either the literal is of a fixed-point type, or it is a bound
3559 -- of a fixed-point type, with type universal real. In either case we
3560 -- obtain the desired value from Corresponding_Integer_Value.
3562 elsif Kind = N_Real_Literal then
3563 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3564 return Corresponding_Integer_Value (N);
3566 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3568 elsif Kind = N_Attribute_Reference
3569 and then Attribute_Name (N) = Name_Null_Parameter
3573 -- Otherwise must be character literal
3576 pragma Assert (Kind = N_Character_Literal);
3579 -- Since Character literals of type Standard.Character don't have any
3580 -- defining character literals built for them, they do not have their
3581 -- Entity set, so just use their Char code. Otherwise for user-
3582 -- defined character literals use their Pos value as usual which is
3583 -- the same as the Rep value.
3586 return Char_Literal_Value (N);
3588 return Enumeration_Rep (Ent);
3597 function Expr_Value (N : Node_Id) return Uint is
3598 Kind : constant Node_Kind := Nkind (N);
3599 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3604 -- If already in cache, then we know it's compile time known and we can
3605 -- return the value that was previously stored in the cache since
3606 -- compile time known values cannot change.
3608 if CV_Ent.N = N then
3612 -- Otherwise proceed to test value
3614 if Is_Entity_Name (N) then
3617 -- An enumeration literal that was either in the source or created as
3618 -- a result of static evaluation.
3620 if Ekind (Ent) = E_Enumeration_Literal then
3621 Val := Enumeration_Pos (Ent);
3623 -- A user defined static constant
3626 pragma Assert (Ekind (Ent) = E_Constant);
3627 Val := Expr_Value (Constant_Value (Ent));
3630 -- An integer literal that was either in the source or created as a
3631 -- result of static evaluation.
3633 elsif Kind = N_Integer_Literal then
3636 -- A real literal for a fixed-point type. This must be the fixed-point
3637 -- case, either the literal is of a fixed-point type, or it is a bound
3638 -- of a fixed-point type, with type universal real. In either case we
3639 -- obtain the desired value from Corresponding_Integer_Value.
3641 elsif Kind = N_Real_Literal then
3643 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3644 Val := Corresponding_Integer_Value (N);
3646 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3648 elsif Kind = N_Attribute_Reference
3649 and then Attribute_Name (N) = Name_Null_Parameter
3653 -- Otherwise must be character literal
3656 pragma Assert (Kind = N_Character_Literal);
3659 -- Since Character literals of type Standard.Character don't
3660 -- have any defining character literals built for them, they
3661 -- do not have their Entity set, so just use their Char
3662 -- code. Otherwise for user-defined character literals use
3663 -- their Pos value as usual.
3666 Val := Char_Literal_Value (N);
3668 Val := Enumeration_Pos (Ent);
3672 -- Come here with Val set to value to be returned, set cache
3683 function Expr_Value_E (N : Node_Id) return Entity_Id is
3684 Ent : constant Entity_Id := Entity (N);
3687 if Ekind (Ent) = E_Enumeration_Literal then
3690 pragma Assert (Ekind (Ent) = E_Constant);
3691 return Expr_Value_E (Constant_Value (Ent));
3699 function Expr_Value_R (N : Node_Id) return Ureal is
3700 Kind : constant Node_Kind := Nkind (N);
3705 if Kind = N_Real_Literal then
3708 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3710 pragma Assert (Ekind (Ent) = E_Constant);
3711 return Expr_Value_R (Constant_Value (Ent));
3713 elsif Kind = N_Integer_Literal then
3714 return UR_From_Uint (Expr_Value (N));
3716 -- Strange case of VAX literals, which are at this stage transformed
3717 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3718 -- Exp_Vfpt for further details.
3720 elsif Vax_Float (Etype (N))
3721 and then Nkind (N) = N_Unchecked_Type_Conversion
3723 Expr := Expression (N);
3725 if Nkind (Expr) = N_Function_Call
3726 and then Present (Parameter_Associations (Expr))
3728 Expr := First (Parameter_Associations (Expr));
3730 if Nkind (Expr) = N_Real_Literal then
3731 return Realval (Expr);
3735 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3737 elsif Kind = N_Attribute_Reference
3738 and then Attribute_Name (N) = Name_Null_Parameter
3743 -- If we fall through, we have a node that cannot be interpreted as a
3744 -- compile time constant. That is definitely an error.
3746 raise Program_Error;
3753 function Expr_Value_S (N : Node_Id) return Node_Id is
3755 if Nkind (N) = N_String_Literal then
3758 pragma Assert (Ekind (Entity (N)) = E_Constant);
3759 return Expr_Value_S (Constant_Value (Entity (N)));
3763 ----------------------------------
3764 -- Find_Universal_Operator_Type --
3765 ----------------------------------
3767 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
3768 PN : constant Node_Id := Parent (N);
3769 Call : constant Node_Id := Original_Node (N);
3770 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
3772 Is_Fix : constant Boolean :=
3773 Nkind (N) in N_Binary_Op
3774 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
3775 -- A mixed-mode operation in this context indicates the presence of
3776 -- fixed-point type in the designated package.
3778 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
3779 -- Case where N is a relational (or membership) operator (else it is an
3782 In_Membership : constant Boolean :=
3783 Nkind (PN) in N_Membership_Test
3785 Nkind (Right_Opnd (PN)) = N_Range
3787 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
3789 Is_Universal_Numeric_Type
3790 (Etype (Low_Bound (Right_Opnd (PN))))
3792 Is_Universal_Numeric_Type
3793 (Etype (High_Bound (Right_Opnd (PN))));
3794 -- Case where N is part of a membership test with a universal range
3798 Typ1 : Entity_Id := Empty;
3801 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
3802 -- Check whether one operand is a mixed-mode operation that requires the
3803 -- presence of a fixed-point type. Given that all operands are universal
3804 -- and have been constant-folded, retrieve the original function call.
3806 ---------------------------
3807 -- Is_Mixed_Mode_Operand --
3808 ---------------------------
3810 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
3811 Onod : constant Node_Id := Original_Node (Op);
3813 return Nkind (Onod) = N_Function_Call
3814 and then Present (Next_Actual (First_Actual (Onod)))
3815 and then Etype (First_Actual (Onod)) /=
3816 Etype (Next_Actual (First_Actual (Onod)));
3817 end Is_Mixed_Mode_Operand;
3819 -- Start of processing for Find_Universal_Operator_Type
3822 if Nkind (Call) /= N_Function_Call
3823 or else Nkind (Name (Call)) /= N_Expanded_Name
3827 -- There are several cases where the context does not imply the type of
3829 -- - the universal expression appears in a type conversion;
3830 -- - the expression is a relational operator applied to universal
3832 -- - the expression is a membership test with a universal operand
3833 -- and a range with universal bounds.
3835 elsif Nkind (Parent (N)) = N_Type_Conversion
3836 or else Is_Relational
3837 or else In_Membership
3839 Pack := Entity (Prefix (Name (Call)));
3841 -- If the prefix is a package declared elsewhere, iterate over its
3842 -- visible entities, otherwise iterate over all declarations in the
3843 -- designated scope.
3845 if Ekind (Pack) = E_Package
3846 and then not In_Open_Scopes (Pack)
3848 Priv_E := First_Private_Entity (Pack);
3854 E := First_Entity (Pack);
3855 while Present (E) and then E /= Priv_E loop
3856 if Is_Numeric_Type (E)
3857 and then Nkind (Parent (E)) /= N_Subtype_Declaration
3858 and then Comes_From_Source (E)
3859 and then Is_Integer_Type (E) = Is_Int
3861 (Nkind (N) in N_Unary_Op
3862 or else Is_Relational
3863 or else Is_Fixed_Point_Type (E) = Is_Fix)
3868 -- Before emitting an error, check for the presence of a
3869 -- mixed-mode operation that specifies a fixed point type.
3873 (Is_Mixed_Mode_Operand (Left_Opnd (N))
3874 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
3875 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
3878 if Is_Fixed_Point_Type (E) then
3883 -- More than one type of the proper class declared in P
3885 Error_Msg_N ("ambiguous operation", N);
3886 Error_Msg_Sloc := Sloc (Typ1);
3887 Error_Msg_N ("\possible interpretation (inherited)#", N);
3888 Error_Msg_Sloc := Sloc (E);
3889 Error_Msg_N ("\possible interpretation (inherited)#", N);
3899 end Find_Universal_Operator_Type;
3901 --------------------------
3902 -- Flag_Non_Static_Expr --
3903 --------------------------
3905 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
3907 if Error_Posted (Expr) and then not All_Errors_Mode then
3910 Error_Msg_F (Msg, Expr);
3911 Why_Not_Static (Expr);
3913 end Flag_Non_Static_Expr;
3919 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
3920 Loc : constant Source_Ptr := Sloc (N);
3921 Typ : constant Entity_Id := Etype (N);
3924 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
3926 -- We now have the literal with the right value, both the actual type
3927 -- and the expected type of this literal are taken from the expression
3928 -- that was evaluated.
3931 Set_Is_Static_Expression (N, Static);
3940 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
3941 Loc : constant Source_Ptr := Sloc (N);
3942 Typ : Entity_Id := Etype (N);
3946 -- If we are folding a named number, retain the entity in the literal,
3949 if Is_Entity_Name (N)
3950 and then Ekind (Entity (N)) = E_Named_Integer
3957 if Is_Private_Type (Typ) then
3958 Typ := Full_View (Typ);
3961 -- For a result of type integer, substitute an N_Integer_Literal node
3962 -- for the result of the compile time evaluation of the expression.
3963 -- For ASIS use, set a link to the original named number when not in
3964 -- a generic context.
3966 if Is_Integer_Type (Typ) then
3967 Rewrite (N, Make_Integer_Literal (Loc, Val));
3969 Set_Original_Entity (N, Ent);
3971 -- Otherwise we have an enumeration type, and we substitute either
3972 -- an N_Identifier or N_Character_Literal to represent the enumeration
3973 -- literal corresponding to the given value, which must always be in
3974 -- range, because appropriate tests have already been made for this.
3976 else pragma Assert (Is_Enumeration_Type (Typ));
3977 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
3980 -- We now have the literal with the right value, both the actual type
3981 -- and the expected type of this literal are taken from the expression
3982 -- that was evaluated.
3985 Set_Is_Static_Expression (N, Static);
3994 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
3995 Loc : constant Source_Ptr := Sloc (N);
3996 Typ : constant Entity_Id := Etype (N);
4000 -- If we are folding a named number, retain the entity in the literal,
4003 if Is_Entity_Name (N)
4004 and then Ekind (Entity (N)) = E_Named_Real
4011 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4013 -- Set link to original named number, for ASIS use
4015 Set_Original_Entity (N, Ent);
4017 -- Both the actual and expected type comes from the original expression
4020 Set_Is_Static_Expression (N, Static);
4029 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4033 for J in 0 .. B'Last loop
4039 if Non_Binary_Modulus (T) then
4040 V := V mod Modulus (T);
4046 --------------------
4047 -- Get_String_Val --
4048 --------------------
4050 function Get_String_Val (N : Node_Id) return Node_Id is
4052 if Nkind (N) = N_String_Literal then
4055 elsif Nkind (N) = N_Character_Literal then
4059 pragma Assert (Is_Entity_Name (N));
4060 return Get_String_Val (Constant_Value (Entity (N)));
4068 procedure Initialize is
4070 CV_Cache := (others => (Node_High_Bound, Uint_0));
4073 --------------------
4074 -- In_Subrange_Of --
4075 --------------------
4077 function In_Subrange_Of
4080 Fixed_Int : Boolean := False) return Boolean
4089 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4092 -- Never in range if both types are not scalar. Don't know if this can
4093 -- actually happen, but just in case.
4095 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
4098 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4099 -- definitely not compatible with T2.
4101 elsif Is_Floating_Point_Type (T1)
4102 and then Has_Infinities (T1)
4103 and then Is_Floating_Point_Type (T2)
4104 and then not Has_Infinities (T2)
4109 L1 := Type_Low_Bound (T1);
4110 H1 := Type_High_Bound (T1);
4112 L2 := Type_Low_Bound (T2);
4113 H2 := Type_High_Bound (T2);
4115 -- Check bounds to see if comparison possible at compile time
4117 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4119 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4124 -- If bounds not comparable at compile time, then the bounds of T2
4125 -- must be compile time known or we cannot answer the query.
4127 if not Compile_Time_Known_Value (L2)
4128 or else not Compile_Time_Known_Value (H2)
4133 -- If the bounds of T1 are know at compile time then use these
4134 -- ones, otherwise use the bounds of the base type (which are of
4135 -- course always static).
4137 if not Compile_Time_Known_Value (L1) then
4138 L1 := Type_Low_Bound (Base_Type (T1));
4141 if not Compile_Time_Known_Value (H1) then
4142 H1 := Type_High_Bound (Base_Type (T1));
4145 -- Fixed point types should be considered as such only if
4146 -- flag Fixed_Int is set to False.
4148 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4149 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4150 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4153 Expr_Value_R (L2) <= Expr_Value_R (L1)
4155 Expr_Value_R (H2) >= Expr_Value_R (H1);
4159 Expr_Value (L2) <= Expr_Value (L1)
4161 Expr_Value (H2) >= Expr_Value (H1);
4166 -- If any exception occurs, it means that we have some bug in the compiler
4167 -- possibly triggered by a previous error, or by some unforeseen peculiar
4168 -- occurrence. However, this is only an optimization attempt, so there is
4169 -- really no point in crashing the compiler. Instead we just decide, too
4170 -- bad, we can't figure out the answer in this case after all.
4175 -- Debug flag K disables this behavior (useful for debugging)
4177 if Debug_Flag_K then
4188 function Is_In_Range
4191 Assume_Valid : Boolean := False;
4192 Fixed_Int : Boolean := False;
4193 Int_Real : Boolean := False) return Boolean
4196 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
4204 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4205 Typ : constant Entity_Id := Etype (Lo);
4208 if not Compile_Time_Known_Value (Lo)
4209 or else not Compile_Time_Known_Value (Hi)
4214 if Is_Discrete_Type (Typ) then
4215 return Expr_Value (Lo) > Expr_Value (Hi);
4218 pragma Assert (Is_Real_Type (Typ));
4219 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4223 -----------------------------
4224 -- Is_OK_Static_Expression --
4225 -----------------------------
4227 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4229 return Is_Static_Expression (N)
4230 and then not Raises_Constraint_Error (N);
4231 end Is_OK_Static_Expression;
4233 ------------------------
4234 -- Is_OK_Static_Range --
4235 ------------------------
4237 -- A static range is a range whose bounds are static expressions, or a
4238 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4239 -- We have already converted range attribute references, so we get the
4240 -- "or" part of this rule without needing a special test.
4242 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4244 return Is_OK_Static_Expression (Low_Bound (N))
4245 and then Is_OK_Static_Expression (High_Bound (N));
4246 end Is_OK_Static_Range;
4248 --------------------------
4249 -- Is_OK_Static_Subtype --
4250 --------------------------
4252 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4253 -- neither bound raises constraint error when evaluated.
4255 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4256 Base_T : constant Entity_Id := Base_Type (Typ);
4257 Anc_Subt : Entity_Id;
4260 -- First a quick check on the non static subtype flag. As described
4261 -- in further detail in Einfo, this flag is not decisive in all cases,
4262 -- but if it is set, then the subtype is definitely non-static.
4264 if Is_Non_Static_Subtype (Typ) then
4268 Anc_Subt := Ancestor_Subtype (Typ);
4270 if Anc_Subt = Empty then
4274 if Is_Generic_Type (Root_Type (Base_T))
4275 or else Is_Generic_Actual_Type (Base_T)
4281 elsif Is_String_Type (Typ) then
4283 Ekind (Typ) = E_String_Literal_Subtype
4285 (Is_OK_Static_Subtype (Component_Type (Typ))
4286 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4290 elsif Is_Scalar_Type (Typ) then
4291 if Base_T = Typ then
4295 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4296 -- Get_Type_{Low,High}_Bound.
4298 return Is_OK_Static_Subtype (Anc_Subt)
4299 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4300 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4303 -- Types other than string and scalar types are never static
4308 end Is_OK_Static_Subtype;
4310 ---------------------
4311 -- Is_Out_Of_Range --
4312 ---------------------
4314 function Is_Out_Of_Range
4317 Assume_Valid : Boolean := False;
4318 Fixed_Int : Boolean := False;
4319 Int_Real : Boolean := False) return Boolean
4322 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real)
4324 end Is_Out_Of_Range;
4326 ---------------------
4327 -- Is_Static_Range --
4328 ---------------------
4330 -- A static range is a range whose bounds are static expressions, or a
4331 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4332 -- We have already converted range attribute references, so we get the
4333 -- "or" part of this rule without needing a special test.
4335 function Is_Static_Range (N : Node_Id) return Boolean is
4337 return Is_Static_Expression (Low_Bound (N))
4338 and then Is_Static_Expression (High_Bound (N));
4339 end Is_Static_Range;
4341 -----------------------
4342 -- Is_Static_Subtype --
4343 -----------------------
4345 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4347 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4348 Base_T : constant Entity_Id := Base_Type (Typ);
4349 Anc_Subt : Entity_Id;
4352 -- First a quick check on the non static subtype flag. As described
4353 -- in further detail in Einfo, this flag is not decisive in all cases,
4354 -- but if it is set, then the subtype is definitely non-static.
4356 if Is_Non_Static_Subtype (Typ) then
4360 Anc_Subt := Ancestor_Subtype (Typ);
4362 if Anc_Subt = Empty then
4366 if Is_Generic_Type (Root_Type (Base_T))
4367 or else Is_Generic_Actual_Type (Base_T)
4373 elsif Is_String_Type (Typ) then
4375 Ekind (Typ) = E_String_Literal_Subtype
4377 (Is_Static_Subtype (Component_Type (Typ))
4378 and then Is_Static_Subtype (Etype (First_Index (Typ))));
4382 elsif Is_Scalar_Type (Typ) then
4383 if Base_T = Typ then
4387 return Is_Static_Subtype (Anc_Subt)
4388 and then Is_Static_Expression (Type_Low_Bound (Typ))
4389 and then Is_Static_Expression (Type_High_Bound (Typ));
4392 -- Types other than string and scalar types are never static
4397 end Is_Static_Subtype;
4399 --------------------
4400 -- Not_Null_Range --
4401 --------------------
4403 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4404 Typ : constant Entity_Id := Etype (Lo);
4407 if not Compile_Time_Known_Value (Lo)
4408 or else not Compile_Time_Known_Value (Hi)
4413 if Is_Discrete_Type (Typ) then
4414 return Expr_Value (Lo) <= Expr_Value (Hi);
4417 pragma Assert (Is_Real_Type (Typ));
4419 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
4427 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
4429 -- We allow a maximum of 500,000 bits which seems a reasonable limit
4431 if Bits < 500_000 then
4435 Error_Msg_N ("static value too large, capacity exceeded", N);
4444 procedure Out_Of_Range (N : Node_Id) is
4446 -- If we have the static expression case, then this is an illegality
4447 -- in Ada 95 mode, except that in an instance, we never generate an
4448 -- error (if the error is legitimate, it was already diagnosed in the
4449 -- template). The expression to compute the length of a packed array is
4450 -- attached to the array type itself, and deserves a separate message.
4452 if Is_Static_Expression (N)
4453 and then not In_Instance
4454 and then not In_Inlined_Body
4455 and then Ada_Version >= Ada_95
4457 if Nkind (Parent (N)) = N_Defining_Identifier
4458 and then Is_Array_Type (Parent (N))
4459 and then Present (Packed_Array_Type (Parent (N)))
4460 and then Present (First_Rep_Item (Parent (N)))
4463 ("length of packed array must not exceed Integer''Last",
4464 First_Rep_Item (Parent (N)));
4465 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
4468 Apply_Compile_Time_Constraint_Error
4469 (N, "value not in range of}", CE_Range_Check_Failed);
4472 -- Here we generate a warning for the Ada 83 case, or when we are in an
4473 -- instance, or when we have a non-static expression case.
4476 Apply_Compile_Time_Constraint_Error
4477 (N, "value not in range of}?", CE_Range_Check_Failed);
4481 -------------------------
4482 -- Rewrite_In_Raise_CE --
4483 -------------------------
4485 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
4486 Typ : constant Entity_Id := Etype (N);
4489 -- If we want to raise CE in the condition of a N_Raise_CE node
4490 -- we may as well get rid of the condition.
4492 if Present (Parent (N))
4493 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
4495 Set_Condition (Parent (N), Empty);
4497 -- If the expression raising CE is a N_Raise_CE node, we can use that
4498 -- one. We just preserve the type of the context.
4500 elsif Nkind (Exp) = N_Raise_Constraint_Error then
4504 -- Else build an explcit N_Raise_CE
4508 Make_Raise_Constraint_Error (Sloc (Exp),
4509 Reason => CE_Range_Check_Failed));
4510 Set_Raises_Constraint_Error (N);
4513 end Rewrite_In_Raise_CE;
4515 ---------------------
4516 -- String_Type_Len --
4517 ---------------------
4519 function String_Type_Len (Stype : Entity_Id) return Uint is
4520 NT : constant Entity_Id := Etype (First_Index (Stype));
4524 if Is_OK_Static_Subtype (NT) then
4527 T := Base_Type (NT);
4530 return Expr_Value (Type_High_Bound (T)) -
4531 Expr_Value (Type_Low_Bound (T)) + 1;
4532 end String_Type_Len;
4534 ------------------------------------
4535 -- Subtypes_Statically_Compatible --
4536 ------------------------------------
4538 function Subtypes_Statically_Compatible
4540 T2 : Entity_Id) return Boolean
4543 if Is_Scalar_Type (T1) then
4545 -- Definitely compatible if we match
4547 if Subtypes_Statically_Match (T1, T2) then
4550 -- If either subtype is nonstatic then they're not compatible
4552 elsif not Is_Static_Subtype (T1)
4553 or else not Is_Static_Subtype (T2)
4557 -- If either type has constraint error bounds, then consider that
4558 -- they match to avoid junk cascaded errors here.
4560 elsif not Is_OK_Static_Subtype (T1)
4561 or else not Is_OK_Static_Subtype (T2)
4565 -- Base types must match, but we don't check that (should
4566 -- we???) but we do at least check that both types are
4567 -- real, or both types are not real.
4569 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
4572 -- Here we check the bounds
4576 LB1 : constant Node_Id := Type_Low_Bound (T1);
4577 HB1 : constant Node_Id := Type_High_Bound (T1);
4578 LB2 : constant Node_Id := Type_Low_Bound (T2);
4579 HB2 : constant Node_Id := Type_High_Bound (T2);
4582 if Is_Real_Type (T1) then
4584 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4586 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4588 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4592 (Expr_Value (LB1) > Expr_Value (HB1))
4594 (Expr_Value (LB2) <= Expr_Value (LB1)
4596 Expr_Value (HB1) <= Expr_Value (HB2));
4601 elsif Is_Access_Type (T1) then
4602 return not Is_Constrained (T2)
4603 or else Subtypes_Statically_Match
4604 (Designated_Type (T1), Designated_Type (T2));
4607 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4608 or else Subtypes_Statically_Match (T1, T2);
4610 end Subtypes_Statically_Compatible;
4612 -------------------------------
4613 -- Subtypes_Statically_Match --
4614 -------------------------------
4616 -- Subtypes statically match if they have statically matching constraints
4617 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4618 -- they are the same identical constraint, or if they are static and the
4619 -- values match (RM 4.9.1(1)).
4621 function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
4623 -- A type always statically matches itself
4630 elsif Is_Scalar_Type (T1) then
4632 -- Base types must be the same
4634 if Base_Type (T1) /= Base_Type (T2) then
4638 -- A constrained numeric subtype never matches an unconstrained
4639 -- subtype, i.e. both types must be constrained or unconstrained.
4641 -- To understand the requirement for this test, see RM 4.9.1(1).
4642 -- As is made clear in RM 3.5.4(11), type Integer, for example is
4643 -- a constrained subtype with constraint bounds matching the bounds
4644 -- of its corresponding unconstrained base type. In this situation,
4645 -- Integer and Integer'Base do not statically match, even though
4646 -- they have the same bounds.
4648 -- We only apply this test to types in Standard and types that appear
4649 -- in user programs. That way, we do not have to be too careful about
4650 -- setting Is_Constrained right for Itypes.
4652 if Is_Numeric_Type (T1)
4653 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4654 and then (Scope (T1) = Standard_Standard
4655 or else Comes_From_Source (T1))
4656 and then (Scope (T2) = Standard_Standard
4657 or else Comes_From_Source (T2))
4661 -- A generic scalar type does not statically match its base type
4662 -- (AI-311). In this case we make sure that the formals, which are
4663 -- first subtypes of their bases, are constrained.
4665 elsif Is_Generic_Type (T1)
4666 and then Is_Generic_Type (T2)
4667 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4672 -- If there was an error in either range, then just assume the types
4673 -- statically match to avoid further junk errors.
4675 if Error_Posted (Scalar_Range (T1))
4677 Error_Posted (Scalar_Range (T2))
4682 -- Otherwise both types have bound that can be compared
4685 LB1 : constant Node_Id := Type_Low_Bound (T1);
4686 HB1 : constant Node_Id := Type_High_Bound (T1);
4687 LB2 : constant Node_Id := Type_Low_Bound (T2);
4688 HB2 : constant Node_Id := Type_High_Bound (T2);
4691 -- If the bounds are the same tree node, then match
4693 if LB1 = LB2 and then HB1 = HB2 then
4696 -- Otherwise bounds must be static and identical value
4699 if not Is_Static_Subtype (T1)
4700 or else not Is_Static_Subtype (T2)
4704 -- If either type has constraint error bounds, then say that
4705 -- they match to avoid junk cascaded errors here.
4707 elsif not Is_OK_Static_Subtype (T1)
4708 or else not Is_OK_Static_Subtype (T2)
4712 elsif Is_Real_Type (T1) then
4714 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4716 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4720 Expr_Value (LB1) = Expr_Value (LB2)
4722 Expr_Value (HB1) = Expr_Value (HB2);
4727 -- Type with discriminants
4729 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
4731 -- Because of view exchanges in multiple instantiations, conformance
4732 -- checking might try to match a partial view of a type with no
4733 -- discriminants with a full view that has defaulted discriminants.
4734 -- In such a case, use the discriminant constraint of the full view,
4735 -- which must exist because we know that the two subtypes have the
4738 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
4740 if Is_Private_Type (T2)
4741 and then Present (Full_View (T2))
4742 and then Has_Discriminants (Full_View (T2))
4744 return Subtypes_Statically_Match (T1, Full_View (T2));
4746 elsif Is_Private_Type (T1)
4747 and then Present (Full_View (T1))
4748 and then Has_Discriminants (Full_View (T1))
4750 return Subtypes_Statically_Match (Full_View (T1), T2);
4761 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
4762 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
4770 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
4774 -- Now loop through the discriminant constraints
4776 -- Note: the guard here seems necessary, since it is possible at
4777 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
4779 if Present (DL1) and then Present (DL2) then
4780 DA1 := First_Elmt (DL1);
4781 DA2 := First_Elmt (DL2);
4782 while Present (DA1) loop
4784 Expr1 : constant Node_Id := Node (DA1);
4785 Expr2 : constant Node_Id := Node (DA2);
4788 if not Is_Static_Expression (Expr1)
4789 or else not Is_Static_Expression (Expr2)
4793 -- If either expression raised a constraint error,
4794 -- consider the expressions as matching, since this
4795 -- helps to prevent cascading errors.
4797 elsif Raises_Constraint_Error (Expr1)
4798 or else Raises_Constraint_Error (Expr2)
4802 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
4815 -- A definite type does not match an indefinite or classwide type.
4816 -- However, a generic type with unknown discriminants may be
4817 -- instantiated with a type with no discriminants, and conformance
4818 -- checking on an inherited operation may compare the actual with the
4819 -- subtype that renames it in the instance.
4822 Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
4825 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
4829 elsif Is_Array_Type (T1) then
4831 -- If either subtype is unconstrained then both must be, and if both
4832 -- are unconstrained then no further checking is neede.
4834 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
4835 return not (Is_Constrained (T1) or else Is_Constrained (T2));
4838 -- Both subtypes are constrained, so check that the index subtypes
4839 -- statically match.
4842 Index1 : Node_Id := First_Index (T1);
4843 Index2 : Node_Id := First_Index (T2);
4846 while Present (Index1) loop
4848 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
4853 Next_Index (Index1);
4854 Next_Index (Index2);
4860 elsif Is_Access_Type (T1) then
4861 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
4864 elsif Ekind_In (T1, E_Access_Subprogram_Type,
4865 E_Anonymous_Access_Subprogram_Type)
4869 (Designated_Type (T1),
4870 Designated_Type (T2));
4873 Subtypes_Statically_Match
4874 (Designated_Type (T1),
4875 Designated_Type (T2))
4876 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
4879 -- All other types definitely match
4884 end Subtypes_Statically_Match;
4890 function Test (Cond : Boolean) return Uint is
4899 ---------------------------------
4900 -- Test_Expression_Is_Foldable --
4901 ---------------------------------
4905 procedure Test_Expression_Is_Foldable
4915 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4919 -- If operand is Any_Type, just propagate to result and do not
4920 -- try to fold, this prevents cascaded errors.
4922 if Etype (Op1) = Any_Type then
4923 Set_Etype (N, Any_Type);
4926 -- If operand raises constraint error, then replace node N with the
4927 -- raise constraint error node, and we are obviously not foldable.
4928 -- Note that this replacement inherits the Is_Static_Expression flag
4929 -- from the operand.
4931 elsif Raises_Constraint_Error (Op1) then
4932 Rewrite_In_Raise_CE (N, Op1);
4935 -- If the operand is not static, then the result is not static, and
4936 -- all we have to do is to check the operand since it is now known
4937 -- to appear in a non-static context.
4939 elsif not Is_Static_Expression (Op1) then
4940 Check_Non_Static_Context (Op1);
4941 Fold := Compile_Time_Known_Value (Op1);
4944 -- An expression of a formal modular type is not foldable because
4945 -- the modulus is unknown.
4947 elsif Is_Modular_Integer_Type (Etype (Op1))
4948 and then Is_Generic_Type (Etype (Op1))
4950 Check_Non_Static_Context (Op1);
4953 -- Here we have the case of an operand whose type is OK, which is
4954 -- static, and which does not raise constraint error, we can fold.
4957 Set_Is_Static_Expression (N);
4961 end Test_Expression_Is_Foldable;
4965 procedure Test_Expression_Is_Foldable
4972 Rstat : constant Boolean := Is_Static_Expression (Op1)
4973 and then Is_Static_Expression (Op2);
4979 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4983 -- If either operand is Any_Type, just propagate to result and
4984 -- do not try to fold, this prevents cascaded errors.
4986 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
4987 Set_Etype (N, Any_Type);
4990 -- If left operand raises constraint error, then replace node N with the
4991 -- Raise_Constraint_Error node, and we are obviously not foldable.
4992 -- Is_Static_Expression is set from the two operands in the normal way,
4993 -- and we check the right operand if it is in a non-static context.
4995 elsif Raises_Constraint_Error (Op1) then
4997 Check_Non_Static_Context (Op2);
5000 Rewrite_In_Raise_CE (N, Op1);
5001 Set_Is_Static_Expression (N, Rstat);
5004 -- Similar processing for the case of the right operand. Note that we
5005 -- don't use this routine for the short-circuit case, so we do not have
5006 -- to worry about that special case here.
5008 elsif Raises_Constraint_Error (Op2) then
5010 Check_Non_Static_Context (Op1);
5013 Rewrite_In_Raise_CE (N, Op2);
5014 Set_Is_Static_Expression (N, Rstat);
5017 -- Exclude expressions of a generic modular type, as above
5019 elsif Is_Modular_Integer_Type (Etype (Op1))
5020 and then Is_Generic_Type (Etype (Op1))
5022 Check_Non_Static_Context (Op1);
5025 -- If result is not static, then check non-static contexts on operands
5026 -- since one of them may be static and the other one may not be static.
5028 elsif not Rstat then
5029 Check_Non_Static_Context (Op1);
5030 Check_Non_Static_Context (Op2);
5031 Fold := Compile_Time_Known_Value (Op1)
5032 and then Compile_Time_Known_Value (Op2);
5035 -- Else result is static and foldable. Both operands are static, and
5036 -- neither raises constraint error, so we can definitely fold.
5039 Set_Is_Static_Expression (N);
5044 end Test_Expression_Is_Foldable;
5050 function Test_In_Range
5053 Assume_Valid : Boolean;
5054 Fixed_Int : Boolean;
5055 Int_Real : Boolean) return Range_Membership
5060 pragma Warnings (Off, Assume_Valid);
5061 -- For now Assume_Valid is unreferenced since the current implementation
5062 -- always returns Unknown if N is not a compile time known value, but we
5063 -- keep the parameter to allow for future enhancements in which we try
5064 -- to get the information in the variable case as well.
5067 -- Universal types have no range limits, so always in range
5069 if Typ = Universal_Integer or else Typ = Universal_Real then
5072 -- Never known if not scalar type. Don't know if this can actually
5073 -- happen, but our spec allows it, so we must check!
5075 elsif not Is_Scalar_Type (Typ) then
5078 -- Never known if this is a generic type, since the bounds of generic
5079 -- types are junk. Note that if we only checked for static expressions
5080 -- (instead of compile time known values) below, we would not need this
5081 -- check, because values of a generic type can never be static, but they
5082 -- can be known at compile time.
5084 elsif Is_Generic_Type (Typ) then
5087 -- Never known unless we have a compile time known value
5089 elsif not Compile_Time_Known_Value (N) then
5092 -- General processing with a known compile time value
5103 Lo := Type_Low_Bound (Typ);
5104 Hi := Type_High_Bound (Typ);
5106 LB_Known := Compile_Time_Known_Value (Lo);
5107 HB_Known := Compile_Time_Known_Value (Hi);
5109 -- Fixed point types should be considered as such only if flag
5110 -- Fixed_Int is set to False.
5112 if Is_Floating_Point_Type (Typ)
5113 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
5116 Valr := Expr_Value_R (N);
5118 if LB_Known and HB_Known then
5119 if Valr >= Expr_Value_R (Lo)
5121 Valr <= Expr_Value_R (Hi)
5125 return Out_Of_Range;
5128 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
5130 (HB_Known and then Valr > Expr_Value_R (Hi))
5132 return Out_Of_Range;
5139 Val := Expr_Value (N);
5141 if LB_Known and HB_Known then
5142 if Val >= Expr_Value (Lo)
5144 Val <= Expr_Value (Hi)
5148 return Out_Of_Range;
5151 elsif (LB_Known and then Val < Expr_Value (Lo))
5153 (HB_Known and then Val > Expr_Value (Hi))
5155 return Out_Of_Range;
5169 procedure To_Bits (U : Uint; B : out Bits) is
5171 for J in 0 .. B'Last loop
5172 B (J) := (U / (2 ** J)) mod 2 /= 0;
5176 --------------------
5177 -- Why_Not_Static --
5178 --------------------
5180 procedure Why_Not_Static (Expr : Node_Id) is
5181 N : constant Node_Id := Original_Node (Expr);
5185 procedure Why_Not_Static_List (L : List_Id);
5186 -- A version that can be called on a list of expressions. Finds all
5187 -- non-static violations in any element of the list.
5189 -------------------------
5190 -- Why_Not_Static_List --
5191 -------------------------
5193 procedure Why_Not_Static_List (L : List_Id) is
5197 if Is_Non_Empty_List (L) then
5199 while Present (N) loop
5204 end Why_Not_Static_List;
5206 -- Start of processing for Why_Not_Static
5209 -- If in ACATS mode (debug flag 2), then suppress all these messages,
5210 -- this avoids massive updates to the ACATS base line.
5212 if Debug_Flag_2 then
5216 -- Ignore call on error or empty node
5218 if No (Expr) or else Nkind (Expr) = N_Error then
5222 -- Preprocessing for sub expressions
5224 if Nkind (Expr) in N_Subexpr then
5226 -- Nothing to do if expression is static
5228 if Is_OK_Static_Expression (Expr) then
5232 -- Test for constraint error raised
5234 if Raises_Constraint_Error (Expr) then
5236 ("expression raises exception, cannot be static " &
5237 "(RM 4.9(34))!", N);
5241 -- If no type, then something is pretty wrong, so ignore
5243 Typ := Etype (Expr);
5249 -- Type must be scalar or string type
5251 if not Is_Scalar_Type (Typ)
5252 and then not Is_String_Type (Typ)
5255 ("static expression must have scalar or string type " &
5261 -- If we got through those checks, test particular node kind
5264 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
5267 if Is_Named_Number (E) then
5270 elsif Ekind (E) = E_Constant then
5271 if not Is_Static_Expression (Constant_Value (E)) then
5273 ("& is not a static constant (RM 4.9(5))!", N, E);
5278 ("& is not static constant or named number " &
5279 "(RM 4.9(5))!", N, E);
5282 when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
5283 if Nkind (N) in N_Op_Shift then
5285 ("shift functions are never static (RM 4.9(6,18))!", N);
5288 Why_Not_Static (Left_Opnd (N));
5289 Why_Not_Static (Right_Opnd (N));
5293 Why_Not_Static (Right_Opnd (N));
5295 when N_Attribute_Reference =>
5296 Why_Not_Static_List (Expressions (N));
5298 E := Etype (Prefix (N));
5300 if E = Standard_Void_Type then
5304 -- Special case non-scalar'Size since this is a common error
5306 if Attribute_Name (N) = Name_Size then
5308 ("size attribute is only static for static scalar type " &
5309 "(RM 4.9(7,8))", N);
5313 elsif Is_Array_Type (E) then
5314 if Attribute_Name (N) /= Name_First
5316 Attribute_Name (N) /= Name_Last
5318 Attribute_Name (N) /= Name_Length
5321 ("static array attribute must be Length, First, or Last " &
5324 -- Since we know the expression is not-static (we already
5325 -- tested for this, must mean array is not static).
5329 ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
5334 -- Special case generic types, since again this is a common source
5337 elsif Is_Generic_Actual_Type (E)
5342 ("attribute of generic type is never static " &
5343 "(RM 4.9(7,8))!", N);
5345 elsif Is_Static_Subtype (E) then
5348 elsif Is_Scalar_Type (E) then
5350 ("prefix type for attribute is not static scalar subtype " &
5355 ("static attribute must apply to array/scalar type " &
5356 "(RM 4.9(7,8))!", N);
5359 when N_String_Literal =>
5361 ("subtype of string literal is non-static (RM 4.9(4))!", N);
5363 when N_Explicit_Dereference =>
5365 ("explicit dereference is never static (RM 4.9)!", N);
5367 when N_Function_Call =>
5368 Why_Not_Static_List (Parameter_Associations (N));
5369 Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
5371 when N_Parameter_Association =>
5372 Why_Not_Static (Explicit_Actual_Parameter (N));
5374 when N_Indexed_Component =>
5376 ("indexed component is never static (RM 4.9)!", N);
5378 when N_Procedure_Call_Statement =>
5380 ("procedure call is never static (RM 4.9)!", N);
5382 when N_Qualified_Expression =>
5383 Why_Not_Static (Expression (N));
5385 when N_Aggregate | N_Extension_Aggregate =>
5387 ("an aggregate is never static (RM 4.9)!", N);
5390 Why_Not_Static (Low_Bound (N));
5391 Why_Not_Static (High_Bound (N));
5393 when N_Range_Constraint =>
5394 Why_Not_Static (Range_Expression (N));
5396 when N_Subtype_Indication =>
5397 Why_Not_Static (Constraint (N));
5399 when N_Selected_Component =>
5401 ("selected component is never static (RM 4.9)!", N);
5405 ("slice is never static (RM 4.9)!", N);
5407 when N_Type_Conversion =>
5408 Why_Not_Static (Expression (N));
5410 if not Is_Scalar_Type (Etype (Prefix (N)))
5411 or else not Is_Static_Subtype (Etype (Prefix (N)))
5414 ("static conversion requires static scalar subtype result " &
5418 when N_Unchecked_Type_Conversion =>
5420 ("unchecked type conversion is never static (RM 4.9)!", N);