1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Eval_Fat; use Eval_Fat;
34 with Exp_Util; use Exp_Util;
35 with Nmake; use Nmake;
36 with Nlists; use Nlists;
39 with Sem_Cat; use Sem_Cat;
40 with Sem_Ch8; use Sem_Ch8;
41 with Sem_Res; use Sem_Res;
42 with Sem_Util; use Sem_Util;
43 with Sem_Type; use Sem_Type;
44 with Sem_Warn; use Sem_Warn;
45 with Sinfo; use Sinfo;
46 with Snames; use Snames;
47 with Stand; use Stand;
48 with Stringt; use Stringt;
49 with Tbuild; use Tbuild;
51 package body Sem_Eval is
53 -----------------------------------------
54 -- Handling of Compile Time Evaluation --
55 -----------------------------------------
57 -- The compile time evaluation of expressions is distributed over several
58 -- Eval_xxx procedures. These procedures are called immediatedly after
59 -- a subexpression is resolved and is therefore accomplished in a bottom
60 -- up fashion. The flags are synthesized using the following approach.
62 -- Is_Static_Expression is determined by following the detailed rules
63 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
64 -- flag of the operands in many cases.
66 -- Raises_Constraint_Error is set if any of the operands have the flag
67 -- set or if an attempt to compute the value of the current expression
68 -- results in detection of a runtime constraint error.
70 -- As described in the spec, the requirement is that Is_Static_Expression
71 -- be accurately set, and in addition for nodes for which this flag is set,
72 -- Raises_Constraint_Error must also be set. Furthermore a node which has
73 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
74 -- requirement is that the expression value must be precomputed, and the
75 -- node is either a literal, or the name of a constant entity whose value
76 -- is a static expression.
78 -- The general approach is as follows. First compute Is_Static_Expression.
79 -- If the node is not static, then the flag is left off in the node and
80 -- we are all done. Otherwise for a static node, we test if any of the
81 -- operands will raise constraint error, and if so, propagate the flag
82 -- Raises_Constraint_Error to the result node and we are done (since the
83 -- error was already posted at a lower level).
85 -- For the case of a static node whose operands do not raise constraint
86 -- error, we attempt to evaluate the node. If this evaluation succeeds,
87 -- then the node is replaced by the result of this computation. If the
88 -- evaluation raises constraint error, then we rewrite the node with
89 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
90 -- to post appropriate error messages.
96 type Bits is array (Nat range <>) of Boolean;
97 -- Used to convert unsigned (modular) values for folding logical ops
99 -- The following definitions are used to maintain a cache of nodes that
100 -- have compile time known values. The cache is maintained only for
101 -- discrete types (the most common case), and is populated by calls to
102 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
103 -- since it is possible for the status to change (in particular it is
104 -- possible for a node to get replaced by a constraint error node).
106 CV_Bits : constant := 5;
107 -- Number of low order bits of Node_Id value used to reference entries
108 -- in the cache table.
110 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
111 -- Size of cache for compile time values
113 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
115 type CV_Entry is record
120 type CV_Cache_Array is array (CV_Range) of CV_Entry;
122 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
123 -- This is the actual cache, with entries consisting of node/value pairs,
124 -- and the impossible value Node_High_Bound used for unset entries.
126 -----------------------
127 -- Local Subprograms --
128 -----------------------
130 function From_Bits (B : Bits; T : Entity_Id) return Uint;
131 -- Converts a bit string of length B'Length to a Uint value to be used
132 -- for a target of type T, which is a modular type. This procedure
133 -- includes the necessary reduction by the modulus in the case of a
134 -- non-binary modulus (for a binary modulus, the bit string is the
135 -- right length any way so all is well).
137 function Get_String_Val (N : Node_Id) return Node_Id;
138 -- Given a tree node for a folded string or character value, returns
139 -- the corresponding string literal or character literal (one of the
140 -- two must be available, or the operand would not have been marked
141 -- as foldable in the earlier analysis of the operation).
143 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
144 -- Bits represents the number of bits in an integer value to be computed
145 -- (but the value has not been computed yet). If this value in Bits is
146 -- reasonable, a result of True is returned, with the implication that
147 -- the caller should go ahead and complete the calculation. If the value
148 -- in Bits is unreasonably large, then an error is posted on node N, and
149 -- False is returned (and the caller skips the proposed calculation).
151 procedure Out_Of_Range (N : Node_Id);
152 -- This procedure is called if it is determined that node N, which
153 -- appears in a non-static context, is a compile time known value
154 -- which is outside its range, i.e. the range of Etype. This is used
155 -- in contexts where this is an illegality if N is static, and should
156 -- generate a warning otherwise.
158 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
159 -- N and Exp are nodes representing an expression, Exp is known
160 -- to raise CE. N is rewritten in term of Exp in the optimal way.
162 function String_Type_Len (Stype : Entity_Id) return Uint;
163 -- Given a string type, determines the length of the index type, or,
164 -- if this index type is non-static, the length of the base type of
165 -- this index type. Note that if the string type is itself static,
166 -- then the index type is static, so the second case applies only
167 -- if the string type passed is non-static.
169 function Test (Cond : Boolean) return Uint;
170 pragma Inline (Test);
171 -- This function simply returns the appropriate Boolean'Pos value
172 -- corresponding to the value of Cond as a universal integer. It is
173 -- used for producing the result of the static evaluation of the
176 procedure Test_Expression_Is_Foldable
181 -- Tests to see if expression N whose single operand is Op1 is foldable,
182 -- i.e. the operand value is known at compile time. If the operation is
183 -- foldable, then Fold is True on return, and Stat indicates whether
184 -- the result is static (i.e. both operands were static). Note that it
185 -- is quite possible for Fold to be True, and Stat to be False, since
186 -- there are cases in which we know the value of an operand even though
187 -- it is not technically static (e.g. the static lower bound of a range
188 -- whose upper bound is non-static).
190 -- If Stat is set False on return, then Expression_Is_Foldable makes a
191 -- call to Check_Non_Static_Context on the operand. If Fold is False on
192 -- return, then all processing is complete, and the caller should
193 -- return, since there is nothing else to do.
195 procedure Test_Expression_Is_Foldable
201 -- Same processing, except applies to an expression N with two operands
204 procedure To_Bits (U : Uint; B : out Bits);
205 -- Converts a Uint value to a bit string of length B'Length
207 ------------------------------
208 -- Check_Non_Static_Context --
209 ------------------------------
211 procedure Check_Non_Static_Context (N : Node_Id) is
212 T : constant Entity_Id := Etype (N);
213 Checks_On : constant Boolean :=
214 not Index_Checks_Suppressed (T)
215 and not Range_Checks_Suppressed (T);
218 -- Ignore cases of non-scalar types or error types
220 if T = Any_Type or else not Is_Scalar_Type (T) then
224 -- At this stage we have a scalar type. If we have an expression
225 -- that raises CE, then we already issued a warning or error msg
226 -- so there is nothing more to be done in this routine.
228 if Raises_Constraint_Error (N) then
232 -- Now we have a scalar type which is not marked as raising a
233 -- constraint error exception. The main purpose of this routine
234 -- is to deal with static expressions appearing in a non-static
235 -- context. That means that if we do not have a static expression
236 -- then there is not much to do. The one case that we deal with
237 -- here is that if we have a floating-point value that is out of
238 -- range, then we post a warning that an infinity will result.
240 if not Is_Static_Expression (N) then
241 if Is_Floating_Point_Type (T)
242 and then Is_Out_Of_Range (N, Base_Type (T))
245 ("?float value out of range, infinity will be generated", N);
251 -- Here we have the case of outer level static expression of
252 -- scalar type, where the processing of this procedure is needed.
254 -- For real types, this is where we convert the value to a machine
255 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should
256 -- only need to do this if the parent is a constant declaration,
257 -- since in other cases, gigi should do the necessary conversion
258 -- correctly, but experimentation shows that this is not the case
259 -- on all machines, in particular if we do not convert all literals
260 -- to machine values in non-static contexts, then ACVC test C490001
261 -- fails on Sparc/Solaris and SGI/Irix.
263 if Nkind (N) = N_Real_Literal
264 and then not Is_Machine_Number (N)
265 and then not Is_Generic_Type (Etype (N))
266 and then Etype (N) /= Universal_Real
268 -- Check that value is in bounds before converting to machine
269 -- number, so as not to lose case where value overflows in the
270 -- least significant bit or less. See B490001.
272 if Is_Out_Of_Range (N, Base_Type (T)) then
277 -- Note: we have to copy the node, to avoid problems with conformance
278 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
280 Rewrite (N, New_Copy (N));
282 if not Is_Floating_Point_Type (T) then
284 (N, Corresponding_Integer_Value (N) * Small_Value (T));
286 elsif not UR_Is_Zero (Realval (N)) then
288 -- Note: even though RM 4.9(38) specifies biased rounding,
289 -- this has been modified by AI-100 in order to prevent
290 -- confusing differences in rounding between static and
291 -- non-static expressions. AI-100 specifies that the effect
292 -- of such rounding is implementation dependent, and in GNAT
293 -- we round to nearest even to match the run-time behavior.
296 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
299 Set_Is_Machine_Number (N);
302 -- Check for out of range universal integer. This is a non-static
303 -- context, so the integer value must be in range of the runtime
304 -- representation of universal integers.
306 -- We do this only within an expression, because that is the only
307 -- case in which non-static universal integer values can occur, and
308 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
309 -- called in contexts like the expression of a number declaration where
310 -- we certainly want to allow out of range values.
312 if Etype (N) = Universal_Integer
313 and then Nkind (N) = N_Integer_Literal
314 and then Nkind (Parent (N)) in N_Subexpr
316 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
318 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
320 Apply_Compile_Time_Constraint_Error
321 (N, "non-static universal integer value out of range?",
322 CE_Range_Check_Failed);
324 -- Check out of range of base type
326 elsif Is_Out_Of_Range (N, Base_Type (T)) then
329 -- Give warning if outside subtype (where one or both of the
330 -- bounds of the subtype is static). This warning is omitted
331 -- if the expression appears in a range that could be null
332 -- (warnings are handled elsewhere for this case).
334 elsif T /= Base_Type (T)
335 and then Nkind (Parent (N)) /= N_Range
337 if Is_In_Range (N, T) then
340 elsif Is_Out_Of_Range (N, T) then
341 Apply_Compile_Time_Constraint_Error
342 (N, "value not in range of}?", CE_Range_Check_Failed);
345 Enable_Range_Check (N);
348 Set_Do_Range_Check (N, False);
351 end Check_Non_Static_Context;
353 ---------------------------------
354 -- Check_String_Literal_Length --
355 ---------------------------------
357 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
359 if not Raises_Constraint_Error (N)
360 and then Is_Constrained (Ttype)
363 UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
365 Apply_Compile_Time_Constraint_Error
366 (N, "string length wrong for}?",
367 CE_Length_Check_Failed,
372 end Check_String_Literal_Length;
374 --------------------------
375 -- Compile_Time_Compare --
376 --------------------------
378 function Compile_Time_Compare
380 Rec : Boolean := False)
381 return Compare_Result
383 Ltyp : constant Entity_Id := Etype (L);
384 Rtyp : constant Entity_Id := Etype (R);
386 procedure Compare_Decompose
390 -- This procedure decomposes the node N into an expression node
391 -- and a signed offset, so that the value of N is equal to the
392 -- value of R plus the value V (which may be negative). If no
393 -- such decomposition is possible, then on return R is a copy
394 -- of N, and V is set to zero.
396 function Compare_Fixup (N : Node_Id) return Node_Id;
397 -- This function deals with replacing 'Last and 'First references
398 -- with their corresponding type bounds, which we then can compare.
399 -- The argument is the original node, the result is the identity,
400 -- unless we have a 'Last/'First reference in which case the value
401 -- returned is the appropriate type bound.
403 function Is_Same_Value (L, R : Node_Id) return Boolean;
404 -- Returns True iff L and R represent expressions that definitely
405 -- have identical (but not necessarily compile time known) values
406 -- Indeed the caller is expected to have already dealt with the
407 -- cases of compile time known values, so these are not tested here.
409 -----------------------
410 -- Compare_Decompose --
411 -----------------------
413 procedure Compare_Decompose
419 if Nkind (N) = N_Op_Add
420 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
423 V := Intval (Right_Opnd (N));
426 elsif Nkind (N) = N_Op_Subtract
427 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
430 V := UI_Negate (Intval (Right_Opnd (N)));
433 elsif Nkind (N) = N_Attribute_Reference then
435 if Attribute_Name (N) = Name_Succ then
436 R := First (Expressions (N));
440 elsif Attribute_Name (N) = Name_Pred then
441 R := First (Expressions (N));
449 end Compare_Decompose;
455 function Compare_Fixup (N : Node_Id) return Node_Id is
461 if Nkind (N) = N_Attribute_Reference
462 and then (Attribute_Name (N) = Name_First
464 Attribute_Name (N) = Name_Last)
466 Xtyp := Etype (Prefix (N));
468 -- If we have no type, then just abandon the attempt to do
469 -- a fixup, this is probably the result of some other error.
475 -- Dereference an access type
477 if Is_Access_Type (Xtyp) then
478 Xtyp := Designated_Type (Xtyp);
481 -- If we don't have an array type at this stage, something
482 -- is peculiar, e.g. another error, and we abandon the attempt
485 if not Is_Array_Type (Xtyp) then
489 -- Ignore unconstrained array, since bounds are not meaningful
491 if not Is_Constrained (Xtyp) then
495 if Ekind (Xtyp) = E_String_Literal_Subtype then
496 if Attribute_Name (N) = Name_First then
497 return String_Literal_Low_Bound (Xtyp);
499 else -- Attribute_Name (N) = Name_Last
500 return Make_Integer_Literal (Sloc (N),
501 Intval => Intval (String_Literal_Low_Bound (Xtyp))
502 + String_Literal_Length (Xtyp));
506 -- Find correct index type
508 Indx := First_Index (Xtyp);
510 if Present (Expressions (N)) then
511 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
513 for J in 2 .. Subs loop
514 Indx := Next_Index (Indx);
518 Xtyp := Etype (Indx);
520 if Attribute_Name (N) = Name_First then
521 return Type_Low_Bound (Xtyp);
523 else -- Attribute_Name (N) = Name_Last
524 return Type_High_Bound (Xtyp);
535 function Is_Same_Value (L, R : Node_Id) return Boolean is
536 Lf : constant Node_Id := Compare_Fixup (L);
537 Rf : constant Node_Id := Compare_Fixup (R);
539 function Is_Same_Subscript (L, R : List_Id) return Boolean;
540 -- L, R are the Expressions values from two attribute nodes
541 -- for First or Last attributes. Either may be set to No_List
542 -- if no expressions are present (indicating subscript 1).
543 -- The result is True if both expressions represent the same
544 -- subscript (note that one case is where one subscript is
545 -- missing and the other is explicitly set to 1).
547 -----------------------
548 -- Is_Same_Subscript --
549 -----------------------
551 function Is_Same_Subscript (L, R : List_Id) return Boolean is
557 return Expr_Value (First (R)) = Uint_1;
562 return Expr_Value (First (L)) = Uint_1;
564 return Expr_Value (First (L)) = Expr_Value (First (R));
567 end Is_Same_Subscript;
569 -- Start of processing for Is_Same_Value
572 -- Values are the same if they are the same identifier and the
573 -- identifier refers to a constant object (E_Constant). This
574 -- does not however apply to Float types, since we may have two
575 -- NaN values and they should never compare equal.
577 if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
578 and then Entity (Lf) = Entity (Rf)
579 and then not Is_Floating_Point_Type (Etype (L))
580 and then (Ekind (Entity (Lf)) = E_Constant or else
581 Ekind (Entity (Lf)) = E_In_Parameter or else
582 Ekind (Entity (Lf)) = E_Loop_Parameter)
586 -- Or if they are compile time known and identical
588 elsif Compile_Time_Known_Value (Lf)
590 Compile_Time_Known_Value (Rf)
591 and then Expr_Value (Lf) = Expr_Value (Rf)
595 -- Or if they are both 'First or 'Last values applying to the
596 -- same entity (first and last don't change even if value does)
598 elsif Nkind (Lf) = N_Attribute_Reference
600 Nkind (Rf) = N_Attribute_Reference
601 and then Attribute_Name (Lf) = Attribute_Name (Rf)
602 and then (Attribute_Name (Lf) = Name_First
604 Attribute_Name (Lf) = Name_Last)
605 and then Is_Entity_Name (Prefix (Lf))
606 and then Is_Entity_Name (Prefix (Rf))
607 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
608 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
612 -- All other cases, we can't tell
619 -- Start of processing for Compile_Time_Compare
622 -- If either operand could raise constraint error, then we cannot
623 -- know the result at compile time (since CE may be raised!)
625 if not (Cannot_Raise_Constraint_Error (L)
627 Cannot_Raise_Constraint_Error (R))
632 -- Identical operands are most certainly equal
637 -- If expressions have no types, then do not attempt to determine
638 -- if they are the same, since something funny is going on. One
639 -- case in which this happens is during generic template analysis,
640 -- when bounds are not fully analyzed.
642 elsif No (Ltyp) or else No (Rtyp) then
645 -- We only attempt compile time analysis for scalar values, and
646 -- not for packed arrays represented as modular types, where the
647 -- semantics of comparison is quite different.
649 elsif not Is_Scalar_Type (Ltyp)
650 or else Is_Packed_Array_Type (Ltyp)
654 -- Case where comparison involves two compile time known values
656 elsif Compile_Time_Known_Value (L)
657 and then Compile_Time_Known_Value (R)
659 -- For the floating-point case, we have to be a little careful, since
660 -- at compile time we are dealing with universal exact values, but at
661 -- runtime, these will be in non-exact target form. That's why the
662 -- returned results are LE and GE below instead of LT and GT.
664 if Is_Floating_Point_Type (Ltyp)
666 Is_Floating_Point_Type (Rtyp)
669 Lo : constant Ureal := Expr_Value_R (L);
670 Hi : constant Ureal := Expr_Value_R (R);
682 -- For the integer case we know exactly (note that this includes the
683 -- fixed-point case, where we know the run time integer values now)
687 Lo : constant Uint := Expr_Value (L);
688 Hi : constant Uint := Expr_Value (R);
701 -- Cases where at least one operand is not known at compile time
704 -- Here is where we check for comparisons against maximum bounds of
705 -- types, where we know that no value can be outside the bounds of
706 -- the subtype. Note that this routine is allowed to assume that all
707 -- expressions are within their subtype bounds. Callers wishing to
708 -- deal with possibly invalid values must in any case take special
709 -- steps (e.g. conversions to larger types) to avoid this kind of
710 -- optimization, which is always considered to be valid. We do not
711 -- attempt this optimization with generic types, since the type
712 -- bounds may not be meaningful in this case.
714 -- We are in danger of an infinite recursion here. It does not seem
715 -- useful to go more than one level deep, so the parameter Rec is
716 -- used to protect ourselves against this infinite recursion.
719 and then Is_Discrete_Type (Ltyp)
720 and then Is_Discrete_Type (Rtyp)
721 and then not Is_Generic_Type (Ltyp)
722 and then not Is_Generic_Type (Rtyp)
724 -- See if we can get a decisive check against one operand and
725 -- a bound of the other operand (four possible tests here).
727 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is
728 when LT => return LT;
729 when LE => return LE;
730 when EQ => return LE;
734 case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is
735 when GT => return GT;
736 when GE => return GE;
737 when EQ => return GE;
741 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is
742 when GT => return GT;
743 when GE => return GE;
744 when EQ => return GE;
748 case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is
749 when LT => return LT;
750 when LE => return LE;
751 when EQ => return LE;
756 -- Next attempt is to decompose the expressions to extract
757 -- a constant offset resulting from the use of any of the forms:
764 -- Then we see if the two expressions are the same value, and if so
765 -- the result is obtained by comparing the offsets.
774 Compare_Decompose (L, Lnode, Loffs);
775 Compare_Decompose (R, Rnode, Roffs);
777 if Is_Same_Value (Lnode, Rnode) then
778 if Loffs = Roffs then
781 elsif Loffs < Roffs then
788 -- If the expressions are different, we cannot say at compile
789 -- time how they compare, so we return the Unknown indication.
796 end Compile_Time_Compare;
798 ------------------------------
799 -- Compile_Time_Known_Value --
800 ------------------------------
802 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
803 K : constant Node_Kind := Nkind (Op);
804 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
807 -- Never known at compile time if bad type or raises constraint error
808 -- or empty (latter case occurs only as a result of a previous error)
812 or else Etype (Op) = Any_Type
813 or else Raises_Constraint_Error (Op)
818 -- If this is not a static expression and we are in configurable run
819 -- time mode, then we consider it not known at compile time. This
820 -- avoids anomalies where whether something is permitted with a given
821 -- configurable run-time library depends on how good the compiler is
822 -- at optimizing and knowing that things are constant when they
825 if Configurable_Run_Time_Mode and then not Is_Static_Expression (Op) then
829 -- If we have an entity name, then see if it is the name of a constant
830 -- and if so, test the corresponding constant value, or the name of
831 -- an enumeration literal, which is always a constant.
833 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
835 E : constant Entity_Id := Entity (Op);
839 -- Never known at compile time if it is a packed array value.
840 -- We might want to try to evaluate these at compile time one
841 -- day, but we do not make that attempt now.
843 if Is_Packed_Array_Type (Etype (Op)) then
847 if Ekind (E) = E_Enumeration_Literal then
850 elsif Ekind (E) = E_Constant then
851 V := Constant_Value (E);
852 return Present (V) and then Compile_Time_Known_Value (V);
856 -- We have a value, see if it is compile time known
859 -- Integer literals are worth storing in the cache
861 if K = N_Integer_Literal then
863 CV_Ent.V := Intval (Op);
866 -- Other literals and NULL are known at compile time
869 K = N_Character_Literal
879 -- Any reference to Null_Parameter is known at compile time. No
880 -- other attribute references (that have not already been folded)
881 -- are known at compile time.
883 elsif K = N_Attribute_Reference then
884 return Attribute_Name (Op) = Name_Null_Parameter;
888 -- If we fall through, not known at compile time
892 -- If we get an exception while trying to do this test, then some error
893 -- has occurred, and we simply say that the value is not known after all
898 end Compile_Time_Known_Value;
900 --------------------------------------
901 -- Compile_Time_Known_Value_Or_Aggr --
902 --------------------------------------
904 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
906 -- If we have an entity name, then see if it is the name of a constant
907 -- and if so, test the corresponding constant value, or the name of
908 -- an enumeration literal, which is always a constant.
910 if Is_Entity_Name (Op) then
912 E : constant Entity_Id := Entity (Op);
916 if Ekind (E) = E_Enumeration_Literal then
919 elsif Ekind (E) /= E_Constant then
923 V := Constant_Value (E);
925 and then Compile_Time_Known_Value_Or_Aggr (V);
929 -- We have a value, see if it is compile time known
932 if Compile_Time_Known_Value (Op) then
935 elsif Nkind (Op) = N_Aggregate then
937 if Present (Expressions (Op)) then
942 Expr := First (Expressions (Op));
943 while Present (Expr) loop
944 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
953 if Present (Component_Associations (Op)) then
958 Cass := First (Component_Associations (Op));
959 while Present (Cass) loop
961 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
973 -- All other types of values are not known at compile time
980 end Compile_Time_Known_Value_Or_Aggr;
986 -- This is only called for actuals of functions that are not predefined
987 -- operators (which have already been rewritten as operators at this
988 -- stage), so the call can never be folded, and all that needs doing for
989 -- the actual is to do the check for a non-static context.
991 procedure Eval_Actual (N : Node_Id) is
993 Check_Non_Static_Context (N);
1000 -- Allocators are never static, so all we have to do is to do the
1001 -- check for a non-static context if an expression is present.
1003 procedure Eval_Allocator (N : Node_Id) is
1004 Expr : constant Node_Id := Expression (N);
1007 if Nkind (Expr) = N_Qualified_Expression then
1008 Check_Non_Static_Context (Expression (Expr));
1012 ------------------------
1013 -- Eval_Arithmetic_Op --
1014 ------------------------
1016 -- Arithmetic operations are static functions, so the result is static
1017 -- if both operands are static (RM 4.9(7), 4.9(20)).
1019 procedure Eval_Arithmetic_Op (N : Node_Id) is
1020 Left : constant Node_Id := Left_Opnd (N);
1021 Right : constant Node_Id := Right_Opnd (N);
1022 Ltype : constant Entity_Id := Etype (Left);
1023 Rtype : constant Entity_Id := Etype (Right);
1028 -- If not foldable we are done
1030 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1036 -- Fold for cases where both operands are of integer type
1038 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1040 Left_Int : constant Uint := Expr_Value (Left);
1041 Right_Int : constant Uint := Expr_Value (Right);
1048 Result := Left_Int + Right_Int;
1050 when N_Op_Subtract =>
1051 Result := Left_Int - Right_Int;
1053 when N_Op_Multiply =>
1056 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1058 Result := Left_Int * Right_Int;
1065 -- The exception Constraint_Error is raised by integer
1066 -- division, rem and mod if the right operand is zero.
1068 if Right_Int = 0 then
1069 Apply_Compile_Time_Constraint_Error
1070 (N, "division by zero",
1076 Result := Left_Int / Right_Int;
1081 -- The exception Constraint_Error is raised by integer
1082 -- division, rem and mod if the right operand is zero.
1084 if Right_Int = 0 then
1085 Apply_Compile_Time_Constraint_Error
1086 (N, "mod with zero divisor",
1091 Result := Left_Int mod Right_Int;
1096 -- The exception Constraint_Error is raised by integer
1097 -- division, rem and mod if the right operand is zero.
1099 if Right_Int = 0 then
1100 Apply_Compile_Time_Constraint_Error
1101 (N, "rem with zero divisor",
1107 Result := Left_Int rem Right_Int;
1111 raise Program_Error;
1114 -- Adjust the result by the modulus if the type is a modular type
1116 if Is_Modular_Integer_Type (Ltype) then
1117 Result := Result mod Modulus (Ltype);
1120 Fold_Uint (N, Result, Stat);
1123 -- Cases where at least one operand is a real. We handle the cases
1124 -- of both reals, or mixed/real integer cases (the latter happen
1125 -- only for divide and multiply, and the result is always real).
1127 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1134 if Is_Real_Type (Ltype) then
1135 Left_Real := Expr_Value_R (Left);
1137 Left_Real := UR_From_Uint (Expr_Value (Left));
1140 if Is_Real_Type (Rtype) then
1141 Right_Real := Expr_Value_R (Right);
1143 Right_Real := UR_From_Uint (Expr_Value (Right));
1146 if Nkind (N) = N_Op_Add then
1147 Result := Left_Real + Right_Real;
1149 elsif Nkind (N) = N_Op_Subtract then
1150 Result := Left_Real - Right_Real;
1152 elsif Nkind (N) = N_Op_Multiply then
1153 Result := Left_Real * Right_Real;
1155 else pragma Assert (Nkind (N) = N_Op_Divide);
1156 if UR_Is_Zero (Right_Real) then
1157 Apply_Compile_Time_Constraint_Error
1158 (N, "division by zero", CE_Divide_By_Zero);
1162 Result := Left_Real / Right_Real;
1165 Fold_Ureal (N, Result, Stat);
1168 end Eval_Arithmetic_Op;
1170 ----------------------------
1171 -- Eval_Character_Literal --
1172 ----------------------------
1174 -- Nothing to be done!
1176 procedure Eval_Character_Literal (N : Node_Id) is
1177 pragma Warnings (Off, N);
1181 end Eval_Character_Literal;
1187 -- Static function calls are either calls to predefined operators
1188 -- with static arguments, or calls to functions that rename a literal.
1189 -- Only the latter case is handled here, predefined operators are
1190 -- constant-folded elsewhere.
1191 -- If the function is itself inherited (see 7423-001) the literal of
1192 -- the parent type must be explicitly converted to the return type
1195 procedure Eval_Call (N : Node_Id) is
1196 Loc : constant Source_Ptr := Sloc (N);
1197 Typ : constant Entity_Id := Etype (N);
1201 if Nkind (N) = N_Function_Call
1202 and then No (Parameter_Associations (N))
1203 and then Is_Entity_Name (Name (N))
1204 and then Present (Alias (Entity (Name (N))))
1205 and then Is_Enumeration_Type (Base_Type (Typ))
1207 Lit := Alias (Entity (Name (N)));
1209 while Present (Alias (Lit)) loop
1213 if Ekind (Lit) = E_Enumeration_Literal then
1214 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
1216 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
1218 Rewrite (N, New_Occurrence_Of (Lit, Loc));
1226 ------------------------
1227 -- Eval_Concatenation --
1228 ------------------------
1230 -- Concatenation is a static function, so the result is static if
1231 -- both operands are static (RM 4.9(7), 4.9(21)).
1233 procedure Eval_Concatenation (N : Node_Id) is
1234 Left : constant Node_Id := Left_Opnd (N);
1235 Right : constant Node_Id := Right_Opnd (N);
1236 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
1241 -- Concatenation is never static in Ada 83, so if Ada 83
1242 -- check operand non-static context
1244 if Ada_Version = Ada_83
1245 and then Comes_From_Source (N)
1247 Check_Non_Static_Context (Left);
1248 Check_Non_Static_Context (Right);
1252 -- If not foldable we are done. In principle concatenation that yields
1253 -- any string type is static (i.e. an array type of character types).
1254 -- However, character types can include enumeration literals, and
1255 -- concatenation in that case cannot be described by a literal, so we
1256 -- only consider the operation static if the result is an array of
1257 -- (a descendant of) a predefined character type.
1259 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1261 if (C_Typ = Standard_Character
1262 or else C_Typ = Standard_Wide_Character)
1267 Set_Is_Static_Expression (N, False);
1271 -- Compile time string concatenation.
1273 -- ??? Note that operands that are aggregates can be marked as
1274 -- static, so we should attempt at a later stage to fold
1275 -- concatenations with such aggregates.
1278 Left_Str : constant Node_Id := Get_String_Val (Left);
1280 Right_Str : constant Node_Id := Get_String_Val (Right);
1283 -- Establish new string literal, and store left operand. We make
1284 -- sure to use the special Start_String that takes an operand if
1285 -- the left operand is a string literal. Since this is optimized
1286 -- in the case where that is the most recently created string
1287 -- literal, we ensure efficient time/space behavior for the
1288 -- case of a concatenation of a series of string literals.
1290 if Nkind (Left_Str) = N_String_Literal then
1291 Left_Len := String_Length (Strval (Left_Str));
1292 Start_String (Strval (Left_Str));
1295 Store_String_Char (Char_Literal_Value (Left_Str));
1299 -- Now append the characters of the right operand
1301 if Nkind (Right_Str) = N_String_Literal then
1303 S : constant String_Id := Strval (Right_Str);
1306 for J in 1 .. String_Length (S) loop
1307 Store_String_Char (Get_String_Char (S, J));
1311 Store_String_Char (Char_Literal_Value (Right_Str));
1314 Set_Is_Static_Expression (N, Stat);
1318 -- If left operand is the empty string, the result is the
1319 -- right operand, including its bounds if anomalous.
1322 and then Is_Array_Type (Etype (Right))
1323 and then Etype (Right) /= Any_String
1325 Set_Etype (N, Etype (Right));
1328 Fold_Str (N, End_String, True);
1331 end Eval_Concatenation;
1333 ---------------------------------
1334 -- Eval_Conditional_Expression --
1335 ---------------------------------
1337 -- This GNAT internal construct can never be statically folded, so the
1338 -- only required processing is to do the check for non-static context
1339 -- for the two expression operands.
1341 procedure Eval_Conditional_Expression (N : Node_Id) is
1342 Condition : constant Node_Id := First (Expressions (N));
1343 Then_Expr : constant Node_Id := Next (Condition);
1344 Else_Expr : constant Node_Id := Next (Then_Expr);
1347 Check_Non_Static_Context (Then_Expr);
1348 Check_Non_Static_Context (Else_Expr);
1349 end Eval_Conditional_Expression;
1351 ----------------------
1352 -- Eval_Entity_Name --
1353 ----------------------
1355 -- This procedure is used for identifiers and expanded names other than
1356 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1357 -- static if they denote a static constant (RM 4.9(6)) or if the name
1358 -- denotes an enumeration literal (RM 4.9(22)).
1360 procedure Eval_Entity_Name (N : Node_Id) is
1361 Def_Id : constant Entity_Id := Entity (N);
1365 -- Enumeration literals are always considered to be constants
1366 -- and cannot raise constraint error (RM 4.9(22)).
1368 if Ekind (Def_Id) = E_Enumeration_Literal then
1369 Set_Is_Static_Expression (N);
1372 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1373 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1374 -- it does not violate 10.2.1(8) here, since this is not a variable.
1376 elsif Ekind (Def_Id) = E_Constant then
1378 -- Deferred constants must always be treated as nonstatic
1379 -- outside the scope of their full view.
1381 if Present (Full_View (Def_Id))
1382 and then not In_Open_Scopes (Scope (Def_Id))
1386 Val := Constant_Value (Def_Id);
1389 if Present (Val) then
1390 Set_Is_Static_Expression
1391 (N, Is_Static_Expression (Val)
1392 and then Is_Static_Subtype (Etype (Def_Id)));
1393 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1395 if not Is_Static_Expression (N)
1396 and then not Is_Generic_Type (Etype (N))
1398 Validate_Static_Object_Name (N);
1405 -- Fall through if the name is not static.
1407 Validate_Static_Object_Name (N);
1408 end Eval_Entity_Name;
1410 ----------------------------
1411 -- Eval_Indexed_Component --
1412 ----------------------------
1414 -- Indexed components are never static, so we need to perform the check
1415 -- for non-static context on the index values. Then, we check if the
1416 -- value can be obtained at compile time, even though it is non-static.
1418 procedure Eval_Indexed_Component (N : Node_Id) is
1422 -- Check for non-static context on index values
1424 Expr := First (Expressions (N));
1425 while Present (Expr) loop
1426 Check_Non_Static_Context (Expr);
1430 -- If the indexed component appears in an object renaming declaration
1431 -- then we do not want to try to evaluate it, since in this case we
1432 -- need the identity of the array element.
1434 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
1437 -- Similarly if the indexed component appears as the prefix of an
1438 -- attribute we don't want to evaluate it, because at least for
1439 -- some cases of attributes we need the identify (e.g. Access, Size)
1441 elsif Nkind (Parent (N)) = N_Attribute_Reference then
1445 -- Note: there are other cases, such as the left side of an assignment,
1446 -- or an OUT parameter for a call, where the replacement results in the
1447 -- illegal use of a constant, But these cases are illegal in the first
1448 -- place, so the replacement, though silly, is harmless.
1450 -- Now see if this is a constant array reference
1452 if List_Length (Expressions (N)) = 1
1453 and then Is_Entity_Name (Prefix (N))
1454 and then Ekind (Entity (Prefix (N))) = E_Constant
1455 and then Present (Constant_Value (Entity (Prefix (N))))
1458 Loc : constant Source_Ptr := Sloc (N);
1459 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
1460 Sub : constant Node_Id := First (Expressions (N));
1466 -- Linear one's origin subscript value for array reference
1469 -- Lower bound of the first array index
1472 -- Value from constant array
1475 Atyp := Etype (Arr);
1477 if Is_Access_Type (Atyp) then
1478 Atyp := Designated_Type (Atyp);
1481 -- If we have an array type (we should have but perhaps there
1482 -- are error cases where this is not the case), then see if we
1483 -- can do a constant evaluation of the array reference.
1485 if Is_Array_Type (Atyp) then
1486 if Ekind (Atyp) = E_String_Literal_Subtype then
1487 Lbd := String_Literal_Low_Bound (Atyp);
1489 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
1492 if Compile_Time_Known_Value (Sub)
1493 and then Nkind (Arr) = N_Aggregate
1494 and then Compile_Time_Known_Value (Lbd)
1495 and then Is_Discrete_Type (Component_Type (Atyp))
1497 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
1499 if List_Length (Expressions (Arr)) >= Lin then
1500 Elm := Pick (Expressions (Arr), Lin);
1502 -- If the resulting expression is compile time known,
1503 -- then we can rewrite the indexed component with this
1504 -- value, being sure to mark the result as non-static.
1505 -- We also reset the Sloc, in case this generates an
1506 -- error later on (e.g. 136'Access).
1508 if Compile_Time_Known_Value (Elm) then
1509 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
1510 Set_Is_Static_Expression (N, False);
1518 end Eval_Indexed_Component;
1520 --------------------------
1521 -- Eval_Integer_Literal --
1522 --------------------------
1524 -- Numeric literals are static (RM 4.9(1)), and have already been marked
1525 -- as static by the analyzer. The reason we did it that early is to allow
1526 -- the possibility of turning off the Is_Static_Expression flag after
1527 -- analysis, but before resolution, when integer literals are generated
1528 -- in the expander that do not correspond to static expressions.
1530 procedure Eval_Integer_Literal (N : Node_Id) is
1531 T : constant Entity_Id := Etype (N);
1533 function In_Any_Integer_Context return Boolean;
1534 -- If the literal is resolved with a specific type in a context
1535 -- where the expected type is Any_Integer, there are no range checks
1536 -- on the literal. By the time the literal is evaluated, it carries
1537 -- the type imposed by the enclosing expression, and we must recover
1538 -- the context to determine that Any_Integer is meant.
1540 ----------------------------
1541 -- To_Any_Integer_Context --
1542 ----------------------------
1544 function In_Any_Integer_Context return Boolean is
1545 Par : constant Node_Id := Parent (N);
1546 K : constant Node_Kind := Nkind (Par);
1549 -- Any_Integer also appears in digits specifications for real types,
1550 -- but those have bounds smaller that those of any integer base
1551 -- type, so we can safely ignore these cases.
1553 return K = N_Number_Declaration
1554 or else K = N_Attribute_Reference
1555 or else K = N_Attribute_Definition_Clause
1556 or else K = N_Modular_Type_Definition
1557 or else K = N_Signed_Integer_Type_Definition;
1558 end In_Any_Integer_Context;
1560 -- Start of processing for Eval_Integer_Literal
1564 -- If the literal appears in a non-expression context, then it is
1565 -- certainly appearing in a non-static context, so check it. This
1566 -- is actually a redundant check, since Check_Non_Static_Context
1567 -- would check it, but it seems worth while avoiding the call.
1569 if Nkind (Parent (N)) not in N_Subexpr
1570 and then not In_Any_Integer_Context
1572 Check_Non_Static_Context (N);
1575 -- Modular integer literals must be in their base range
1577 if Is_Modular_Integer_Type (T)
1578 and then Is_Out_Of_Range (N, Base_Type (T))
1582 end Eval_Integer_Literal;
1584 ---------------------
1585 -- Eval_Logical_Op --
1586 ---------------------
1588 -- Logical operations are static functions, so the result is potentially
1589 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1591 procedure Eval_Logical_Op (N : Node_Id) is
1592 Left : constant Node_Id := Left_Opnd (N);
1593 Right : constant Node_Id := Right_Opnd (N);
1598 -- If not foldable we are done
1600 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1606 -- Compile time evaluation of logical operation
1609 Left_Int : constant Uint := Expr_Value (Left);
1610 Right_Int : constant Uint := Expr_Value (Right);
1613 if Is_Modular_Integer_Type (Etype (N)) then
1615 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1616 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1619 To_Bits (Left_Int, Left_Bits);
1620 To_Bits (Right_Int, Right_Bits);
1622 -- Note: should really be able to use array ops instead of
1623 -- these loops, but they weren't working at the time ???
1625 if Nkind (N) = N_Op_And then
1626 for J in Left_Bits'Range loop
1627 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
1630 elsif Nkind (N) = N_Op_Or then
1631 for J in Left_Bits'Range loop
1632 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
1636 pragma Assert (Nkind (N) = N_Op_Xor);
1638 for J in Left_Bits'Range loop
1639 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
1643 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
1647 pragma Assert (Is_Boolean_Type (Etype (N)));
1649 if Nkind (N) = N_Op_And then
1651 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
1653 elsif Nkind (N) = N_Op_Or then
1655 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
1658 pragma Assert (Nkind (N) = N_Op_Xor);
1660 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
1664 end Eval_Logical_Op;
1666 ------------------------
1667 -- Eval_Membership_Op --
1668 ------------------------
1670 -- A membership test is potentially static if the expression is static,
1671 -- and the range is a potentially static range, or is a subtype mark
1672 -- denoting a static subtype (RM 4.9(12)).
1674 procedure Eval_Membership_Op (N : Node_Id) is
1675 Left : constant Node_Id := Left_Opnd (N);
1676 Right : constant Node_Id := Right_Opnd (N);
1685 -- Ignore if error in either operand, except to make sure that
1686 -- Any_Type is properly propagated to avoid junk cascaded errors.
1688 if Etype (Left) = Any_Type
1689 or else Etype (Right) = Any_Type
1691 Set_Etype (N, Any_Type);
1695 -- Case of right operand is a subtype name
1697 if Is_Entity_Name (Right) then
1698 Def_Id := Entity (Right);
1700 if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
1701 and then Is_OK_Static_Subtype (Def_Id)
1703 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
1705 if not Fold or else not Stat then
1709 Check_Non_Static_Context (Left);
1713 -- For string membership tests we will check the length
1716 if not Is_String_Type (Def_Id) then
1717 Lo := Type_Low_Bound (Def_Id);
1718 Hi := Type_High_Bound (Def_Id);
1725 -- Case of right operand is a range
1728 if Is_Static_Range (Right) then
1729 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
1731 if not Fold or else not Stat then
1734 -- If one bound of range raises CE, then don't try to fold
1736 elsif not Is_OK_Static_Range (Right) then
1737 Check_Non_Static_Context (Left);
1742 Check_Non_Static_Context (Left);
1746 -- Here we know range is an OK static range
1748 Lo := Low_Bound (Right);
1749 Hi := High_Bound (Right);
1752 -- For strings we check that the length of the string expression is
1753 -- compatible with the string subtype if the subtype is constrained,
1754 -- or if unconstrained then the test is always true.
1756 if Is_String_Type (Etype (Right)) then
1757 if not Is_Constrained (Etype (Right)) then
1762 Typlen : constant Uint := String_Type_Len (Etype (Right));
1763 Strlen : constant Uint :=
1764 UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
1766 Result := (Typlen = Strlen);
1770 -- Fold the membership test. We know we have a static range and Lo
1771 -- and Hi are set to the expressions for the end points of this range.
1773 elsif Is_Real_Type (Etype (Right)) then
1775 Leftval : constant Ureal := Expr_Value_R (Left);
1778 Result := Expr_Value_R (Lo) <= Leftval
1779 and then Leftval <= Expr_Value_R (Hi);
1784 Leftval : constant Uint := Expr_Value (Left);
1787 Result := Expr_Value (Lo) <= Leftval
1788 and then Leftval <= Expr_Value (Hi);
1792 if Nkind (N) = N_Not_In then
1793 Result := not Result;
1796 Fold_Uint (N, Test (Result), True);
1797 Warn_On_Known_Condition (N);
1798 end Eval_Membership_Op;
1800 ------------------------
1801 -- Eval_Named_Integer --
1802 ------------------------
1804 procedure Eval_Named_Integer (N : Node_Id) is
1807 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
1808 end Eval_Named_Integer;
1810 ---------------------
1811 -- Eval_Named_Real --
1812 ---------------------
1814 procedure Eval_Named_Real (N : Node_Id) is
1817 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
1818 end Eval_Named_Real;
1824 -- Exponentiation is a static functions, so the result is potentially
1825 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1827 procedure Eval_Op_Expon (N : Node_Id) is
1828 Left : constant Node_Id := Left_Opnd (N);
1829 Right : constant Node_Id := Right_Opnd (N);
1834 -- If not foldable we are done
1836 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1842 -- Fold exponentiation operation
1845 Right_Int : constant Uint := Expr_Value (Right);
1850 if Is_Integer_Type (Etype (Left)) then
1852 Left_Int : constant Uint := Expr_Value (Left);
1856 -- Exponentiation of an integer raises the exception
1857 -- Constraint_Error for a negative exponent (RM 4.5.6)
1859 if Right_Int < 0 then
1860 Apply_Compile_Time_Constraint_Error
1861 (N, "integer exponent negative",
1862 CE_Range_Check_Failed,
1867 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
1868 Result := Left_Int ** Right_Int;
1873 if Is_Modular_Integer_Type (Etype (N)) then
1874 Result := Result mod Modulus (Etype (N));
1877 Fold_Uint (N, Result, Stat);
1885 Left_Real : constant Ureal := Expr_Value_R (Left);
1888 -- Cannot have a zero base with a negative exponent
1890 if UR_Is_Zero (Left_Real) then
1892 if Right_Int < 0 then
1893 Apply_Compile_Time_Constraint_Error
1894 (N, "zero ** negative integer",
1895 CE_Range_Check_Failed,
1899 Fold_Ureal (N, Ureal_0, Stat);
1903 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
1914 -- The not operation is a static functions, so the result is potentially
1915 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
1917 procedure Eval_Op_Not (N : Node_Id) is
1918 Right : constant Node_Id := Right_Opnd (N);
1923 -- If not foldable we are done
1925 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
1931 -- Fold not operation
1934 Rint : constant Uint := Expr_Value (Right);
1935 Typ : constant Entity_Id := Etype (N);
1938 -- Negation is equivalent to subtracting from the modulus minus
1939 -- one. For a binary modulus this is equivalent to the ones-
1940 -- component of the original value. For non-binary modulus this
1941 -- is an arbitrary but consistent definition.
1943 if Is_Modular_Integer_Type (Typ) then
1944 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
1947 pragma Assert (Is_Boolean_Type (Typ));
1948 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
1951 Set_Is_Static_Expression (N, Stat);
1955 -------------------------------
1956 -- Eval_Qualified_Expression --
1957 -------------------------------
1959 -- A qualified expression is potentially static if its subtype mark denotes
1960 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
1962 procedure Eval_Qualified_Expression (N : Node_Id) is
1963 Operand : constant Node_Id := Expression (N);
1964 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
1971 -- Can only fold if target is string or scalar and subtype is static
1972 -- Also, do not fold if our parent is an allocator (this is because
1973 -- the qualified expression is really part of the syntactic structure
1974 -- of an allocator, and we do not want to end up with something that
1975 -- corresponds to "new 1" where the 1 is the result of folding a
1976 -- qualified expression).
1978 if not Is_Static_Subtype (Target_Type)
1979 or else Nkind (Parent (N)) = N_Allocator
1981 Check_Non_Static_Context (Operand);
1983 -- If operand is known to raise constraint_error, set the
1984 -- flag on the expression so it does not get optimized away.
1986 if Nkind (Operand) = N_Raise_Constraint_Error then
1987 Set_Raises_Constraint_Error (N);
1993 -- If not foldable we are done
1995 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2000 -- Don't try fold if target type has constraint error bounds
2002 elsif not Is_OK_Static_Subtype (Target_Type) then
2003 Set_Raises_Constraint_Error (N);
2007 -- Here we will fold, save Print_In_Hex indication
2009 Hex := Nkind (Operand) = N_Integer_Literal
2010 and then Print_In_Hex (Operand);
2012 -- Fold the result of qualification
2014 if Is_Discrete_Type (Target_Type) then
2015 Fold_Uint (N, Expr_Value (Operand), Stat);
2017 -- Preserve Print_In_Hex indication
2019 if Hex and then Nkind (N) = N_Integer_Literal then
2020 Set_Print_In_Hex (N);
2023 elsif Is_Real_Type (Target_Type) then
2024 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
2027 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
2030 Set_Is_Static_Expression (N, False);
2032 Check_String_Literal_Length (N, Target_Type);
2038 -- The expression may be foldable but not static
2040 Set_Is_Static_Expression (N, Stat);
2042 if Is_Out_Of_Range (N, Etype (N)) then
2045 end Eval_Qualified_Expression;
2047 -----------------------
2048 -- Eval_Real_Literal --
2049 -----------------------
2051 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2052 -- as static by the analyzer. The reason we did it that early is to allow
2053 -- the possibility of turning off the Is_Static_Expression flag after
2054 -- analysis, but before resolution, when integer literals are generated
2055 -- in the expander that do not correspond to static expressions.
2057 procedure Eval_Real_Literal (N : Node_Id) is
2059 -- If the literal appears in a non-expression context, then it is
2060 -- certainly appearing in a non-static context, so check it.
2062 if Nkind (Parent (N)) not in N_Subexpr then
2063 Check_Non_Static_Context (N);
2066 end Eval_Real_Literal;
2068 ------------------------
2069 -- Eval_Relational_Op --
2070 ------------------------
2072 -- Relational operations are static functions, so the result is static
2073 -- if both operands are static (RM 4.9(7), 4.9(20)).
2075 procedure Eval_Relational_Op (N : Node_Id) is
2076 Left : constant Node_Id := Left_Opnd (N);
2077 Right : constant Node_Id := Right_Opnd (N);
2078 Typ : constant Entity_Id := Etype (Left);
2084 -- One special case to deal with first. If we can tell that
2085 -- the result will be false because the lengths of one or
2086 -- more index subtypes are compile time known and different,
2087 -- then we can replace the entire result by False. We only
2088 -- do this for one dimensional arrays, because the case of
2089 -- multi-dimensional arrays is rare and too much trouble!
2091 if Is_Array_Type (Typ)
2092 and then Number_Dimensions (Typ) = 1
2093 and then (Nkind (N) = N_Op_Eq
2094 or else Nkind (N) = N_Op_Ne)
2096 if Raises_Constraint_Error (Left)
2097 or else Raises_Constraint_Error (Right)
2103 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
2104 -- If Op is an expression for a constrained array with a
2105 -- known at compile time length, then Len is set to this
2106 -- (non-negative length). Otherwise Len is set to minus 1.
2108 -----------------------
2109 -- Get_Static_Length --
2110 -----------------------
2112 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2116 if Nkind (Op) = N_String_Literal then
2117 Len := UI_From_Int (String_Length (Strval (Op)));
2119 elsif not Is_Constrained (Etype (Op)) then
2120 Len := Uint_Minus_1;
2123 T := Etype (First_Index (Etype (Op)));
2125 if Is_Discrete_Type (T)
2127 Compile_Time_Known_Value (Type_Low_Bound (T))
2129 Compile_Time_Known_Value (Type_High_Bound (T))
2131 Len := UI_Max (Uint_0,
2132 Expr_Value (Type_High_Bound (T)) -
2133 Expr_Value (Type_Low_Bound (T)) + 1);
2135 Len := Uint_Minus_1;
2138 end Get_Static_Length;
2144 Get_Static_Length (Left, Len_L);
2145 Get_Static_Length (Right, Len_R);
2147 if Len_L /= Uint_Minus_1
2148 and then Len_R /= Uint_Minus_1
2149 and then Len_L /= Len_R
2151 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2152 Warn_On_Known_Condition (N);
2158 -- Can only fold if type is scalar (don't fold string ops)
2160 if not Is_Scalar_Type (Typ) then
2161 Check_Non_Static_Context (Left);
2162 Check_Non_Static_Context (Right);
2166 -- If not foldable we are done
2168 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2174 -- Integer and Enumeration (discrete) type cases
2176 if Is_Discrete_Type (Typ) then
2178 Left_Int : constant Uint := Expr_Value (Left);
2179 Right_Int : constant Uint := Expr_Value (Right);
2183 when N_Op_Eq => Result := Left_Int = Right_Int;
2184 when N_Op_Ne => Result := Left_Int /= Right_Int;
2185 when N_Op_Lt => Result := Left_Int < Right_Int;
2186 when N_Op_Le => Result := Left_Int <= Right_Int;
2187 when N_Op_Gt => Result := Left_Int > Right_Int;
2188 when N_Op_Ge => Result := Left_Int >= Right_Int;
2191 raise Program_Error;
2194 Fold_Uint (N, Test (Result), Stat);
2200 pragma Assert (Is_Real_Type (Typ));
2203 Left_Real : constant Ureal := Expr_Value_R (Left);
2204 Right_Real : constant Ureal := Expr_Value_R (Right);
2208 when N_Op_Eq => Result := (Left_Real = Right_Real);
2209 when N_Op_Ne => Result := (Left_Real /= Right_Real);
2210 when N_Op_Lt => Result := (Left_Real < Right_Real);
2211 when N_Op_Le => Result := (Left_Real <= Right_Real);
2212 when N_Op_Gt => Result := (Left_Real > Right_Real);
2213 when N_Op_Ge => Result := (Left_Real >= Right_Real);
2216 raise Program_Error;
2219 Fold_Uint (N, Test (Result), Stat);
2223 Warn_On_Known_Condition (N);
2224 end Eval_Relational_Op;
2230 -- Shift operations are intrinsic operations that can never be static,
2231 -- so the only processing required is to perform the required check for
2232 -- a non static context for the two operands.
2234 -- Actually we could do some compile time evaluation here some time ???
2236 procedure Eval_Shift (N : Node_Id) is
2238 Check_Non_Static_Context (Left_Opnd (N));
2239 Check_Non_Static_Context (Right_Opnd (N));
2242 ------------------------
2243 -- Eval_Short_Circuit --
2244 ------------------------
2246 -- A short circuit operation is potentially static if both operands
2247 -- are potentially static (RM 4.9 (13))
2249 procedure Eval_Short_Circuit (N : Node_Id) is
2250 Kind : constant Node_Kind := Nkind (N);
2251 Left : constant Node_Id := Left_Opnd (N);
2252 Right : constant Node_Id := Right_Opnd (N);
2254 Rstat : constant Boolean :=
2255 Is_Static_Expression (Left)
2256 and then Is_Static_Expression (Right);
2259 -- Short circuit operations are never static in Ada 83
2261 if Ada_Version = Ada_83
2262 and then Comes_From_Source (N)
2264 Check_Non_Static_Context (Left);
2265 Check_Non_Static_Context (Right);
2269 -- Now look at the operands, we can't quite use the normal call to
2270 -- Test_Expression_Is_Foldable here because short circuit operations
2271 -- are a special case, they can still be foldable, even if the right
2272 -- operand raises constraint error.
2274 -- If either operand is Any_Type, just propagate to result and
2275 -- do not try to fold, this prevents cascaded errors.
2277 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2278 Set_Etype (N, Any_Type);
2281 -- If left operand raises constraint error, then replace node N with
2282 -- the raise constraint error node, and we are obviously not foldable.
2283 -- Is_Static_Expression is set from the two operands in the normal way,
2284 -- and we check the right operand if it is in a non-static context.
2286 elsif Raises_Constraint_Error (Left) then
2288 Check_Non_Static_Context (Right);
2291 Rewrite_In_Raise_CE (N, Left);
2292 Set_Is_Static_Expression (N, Rstat);
2295 -- If the result is not static, then we won't in any case fold
2297 elsif not Rstat then
2298 Check_Non_Static_Context (Left);
2299 Check_Non_Static_Context (Right);
2303 -- Here the result is static, note that, unlike the normal processing
2304 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
2305 -- the right operand raises constraint error, that's because it is not
2306 -- significant if the left operand is decisive.
2308 Set_Is_Static_Expression (N);
2310 -- It does not matter if the right operand raises constraint error if
2311 -- it will not be evaluated. So deal specially with the cases where
2312 -- the right operand is not evaluated. Note that we will fold these
2313 -- cases even if the right operand is non-static, which is fine, but
2314 -- of course in these cases the result is not potentially static.
2316 Left_Int := Expr_Value (Left);
2318 if (Kind = N_And_Then and then Is_False (Left_Int))
2319 or else (Kind = N_Or_Else and Is_True (Left_Int))
2321 Fold_Uint (N, Left_Int, Rstat);
2325 -- If first operand not decisive, then it does matter if the right
2326 -- operand raises constraint error, since it will be evaluated, so
2327 -- we simply replace the node with the right operand. Note that this
2328 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
2329 -- (both are set to True in Right).
2331 if Raises_Constraint_Error (Right) then
2332 Rewrite_In_Raise_CE (N, Right);
2333 Check_Non_Static_Context (Left);
2337 -- Otherwise the result depends on the right operand
2339 Fold_Uint (N, Expr_Value (Right), Rstat);
2341 end Eval_Short_Circuit;
2347 -- Slices can never be static, so the only processing required is to
2348 -- check for non-static context if an explicit range is given.
2350 procedure Eval_Slice (N : Node_Id) is
2351 Drange : constant Node_Id := Discrete_Range (N);
2354 if Nkind (Drange) = N_Range then
2355 Check_Non_Static_Context (Low_Bound (Drange));
2356 Check_Non_Static_Context (High_Bound (Drange));
2360 -------------------------
2361 -- Eval_String_Literal --
2362 -------------------------
2364 procedure Eval_String_Literal (N : Node_Id) is
2365 Typ : constant Entity_Id := Etype (N);
2366 Bas : constant Entity_Id := Base_Type (Typ);
2372 -- Nothing to do if error type (handles cases like default expressions
2373 -- or generics where we have not yet fully resolved the type)
2375 if Bas = Any_Type or else Bas = Any_String then
2379 -- String literals are static if the subtype is static (RM 4.9(2)), so
2380 -- reset the static expression flag (it was set unconditionally in
2381 -- Analyze_String_Literal) if the subtype is non-static. We tell if
2382 -- the subtype is static by looking at the lower bound.
2384 if Ekind (Typ) = E_String_Literal_Subtype then
2385 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
2386 Set_Is_Static_Expression (N, False);
2390 -- Here if Etype of string literal is normal Etype (not yet possible,
2391 -- but may be possible in future!)
2393 elsif not Is_OK_Static_Expression
2394 (Type_Low_Bound (Etype (First_Index (Typ))))
2396 Set_Is_Static_Expression (N, False);
2400 -- If original node was a type conversion, then result if non-static
2402 if Nkind (Original_Node (N)) = N_Type_Conversion then
2403 Set_Is_Static_Expression (N, False);
2407 -- Test for illegal Ada 95 cases. A string literal is illegal in
2408 -- Ada 95 if its bounds are outside the index base type and this
2409 -- index type is static. This can happen in only two ways. Either
2410 -- the string literal is too long, or it is null, and the lower
2411 -- bound is type'First. In either case it is the upper bound that
2412 -- is out of range of the index type.
2414 if Ada_Version >= Ada_95 then
2415 if Root_Type (Bas) = Standard_String
2417 Root_Type (Bas) = Standard_Wide_String
2419 Xtp := Standard_Positive;
2421 Xtp := Etype (First_Index (Bas));
2424 if Ekind (Typ) = E_String_Literal_Subtype then
2425 Lo := String_Literal_Low_Bound (Typ);
2427 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
2430 Len := String_Length (Strval (N));
2432 if UI_From_Int (Len) > String_Type_Len (Bas) then
2433 Apply_Compile_Time_Constraint_Error
2434 (N, "string literal too long for}", CE_Length_Check_Failed,
2436 Typ => First_Subtype (Bas));
2439 and then not Is_Generic_Type (Xtp)
2441 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
2443 Apply_Compile_Time_Constraint_Error
2444 (N, "null string literal not allowed for}",
2445 CE_Length_Check_Failed,
2447 Typ => First_Subtype (Bas));
2450 end Eval_String_Literal;
2452 --------------------------
2453 -- Eval_Type_Conversion --
2454 --------------------------
2456 -- A type conversion is potentially static if its subtype mark is for a
2457 -- static scalar subtype, and its operand expression is potentially static
2460 procedure Eval_Type_Conversion (N : Node_Id) is
2461 Operand : constant Node_Id := Expression (N);
2462 Source_Type : constant Entity_Id := Etype (Operand);
2463 Target_Type : constant Entity_Id := Etype (N);
2468 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
2469 -- Returns true if type T is an integer type, or if it is a
2470 -- fixed-point type to be treated as an integer (i.e. the flag
2471 -- Conversion_OK is set on the conversion node).
2473 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
2474 -- Returns true if type T is a floating-point type, or if it is a
2475 -- fixed-point type that is not to be treated as an integer (i.e. the
2476 -- flag Conversion_OK is not set on the conversion node).
2478 ------------------------------
2479 -- To_Be_Treated_As_Integer --
2480 ------------------------------
2482 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
2486 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
2487 end To_Be_Treated_As_Integer;
2489 ---------------------------
2490 -- To_Be_Treated_As_Real --
2491 ---------------------------
2493 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
2496 Is_Floating_Point_Type (T)
2497 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
2498 end To_Be_Treated_As_Real;
2500 -- Start of processing for Eval_Type_Conversion
2503 -- Cannot fold if target type is non-static or if semantic error.
2505 if not Is_Static_Subtype (Target_Type) then
2506 Check_Non_Static_Context (Operand);
2509 elsif Error_Posted (N) then
2513 -- If not foldable we are done
2515 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2520 -- Don't try fold if target type has constraint error bounds
2522 elsif not Is_OK_Static_Subtype (Target_Type) then
2523 Set_Raises_Constraint_Error (N);
2527 -- Remaining processing depends on operand types. Note that in the
2528 -- following type test, fixed-point counts as real unless the flag
2529 -- Conversion_OK is set, in which case it counts as integer.
2531 -- Fold conversion, case of string type. The result is not static.
2533 if Is_String_Type (Target_Type) then
2534 Fold_Str (N, Strval (Get_String_Val (Operand)), False);
2538 -- Fold conversion, case of integer target type
2540 elsif To_Be_Treated_As_Integer (Target_Type) then
2545 -- Integer to integer conversion
2547 if To_Be_Treated_As_Integer (Source_Type) then
2548 Result := Expr_Value (Operand);
2550 -- Real to integer conversion
2553 Result := UR_To_Uint (Expr_Value_R (Operand));
2556 -- If fixed-point type (Conversion_OK must be set), then the
2557 -- result is logically an integer, but we must replace the
2558 -- conversion with the corresponding real literal, since the
2559 -- type from a semantic point of view is still fixed-point.
2561 if Is_Fixed_Point_Type (Target_Type) then
2563 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
2565 -- Otherwise result is integer literal
2568 Fold_Uint (N, Result, Stat);
2572 -- Fold conversion, case of real target type
2574 elsif To_Be_Treated_As_Real (Target_Type) then
2579 if To_Be_Treated_As_Real (Source_Type) then
2580 Result := Expr_Value_R (Operand);
2582 Result := UR_From_Uint (Expr_Value (Operand));
2585 Fold_Ureal (N, Result, Stat);
2588 -- Enumeration types
2591 Fold_Uint (N, Expr_Value (Operand), Stat);
2594 if Is_Out_Of_Range (N, Etype (N)) then
2598 end Eval_Type_Conversion;
2604 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
2605 -- are potentially static if the operand is potentially static (RM 4.9(7))
2607 procedure Eval_Unary_Op (N : Node_Id) is
2608 Right : constant Node_Id := Right_Opnd (N);
2613 -- If not foldable we are done
2615 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2621 -- Fold for integer case
2623 if Is_Integer_Type (Etype (N)) then
2625 Rint : constant Uint := Expr_Value (Right);
2629 -- In the case of modular unary plus and abs there is no need
2630 -- to adjust the result of the operation since if the original
2631 -- operand was in bounds the result will be in the bounds of the
2632 -- modular type. However, in the case of modular unary minus the
2633 -- result may go out of the bounds of the modular type and needs
2636 if Nkind (N) = N_Op_Plus then
2639 elsif Nkind (N) = N_Op_Minus then
2640 if Is_Modular_Integer_Type (Etype (N)) then
2641 Result := (-Rint) mod Modulus (Etype (N));
2647 pragma Assert (Nkind (N) = N_Op_Abs);
2651 Fold_Uint (N, Result, Stat);
2654 -- Fold for real case
2656 elsif Is_Real_Type (Etype (N)) then
2658 Rreal : constant Ureal := Expr_Value_R (Right);
2662 if Nkind (N) = N_Op_Plus then
2665 elsif Nkind (N) = N_Op_Minus then
2666 Result := UR_Negate (Rreal);
2669 pragma Assert (Nkind (N) = N_Op_Abs);
2670 Result := abs Rreal;
2673 Fold_Ureal (N, Result, Stat);
2678 -------------------------------
2679 -- Eval_Unchecked_Conversion --
2680 -------------------------------
2682 -- Unchecked conversions can never be static, so the only required
2683 -- processing is to check for a non-static context for the operand.
2685 procedure Eval_Unchecked_Conversion (N : Node_Id) is
2687 Check_Non_Static_Context (Expression (N));
2688 end Eval_Unchecked_Conversion;
2690 --------------------
2691 -- Expr_Rep_Value --
2692 --------------------
2694 function Expr_Rep_Value (N : Node_Id) return Uint is
2695 Kind : constant Node_Kind := Nkind (N);
2699 if Is_Entity_Name (N) then
2702 -- An enumeration literal that was either in the source or
2703 -- created as a result of static evaluation.
2705 if Ekind (Ent) = E_Enumeration_Literal then
2706 return Enumeration_Rep (Ent);
2708 -- A user defined static constant
2711 pragma Assert (Ekind (Ent) = E_Constant);
2712 return Expr_Rep_Value (Constant_Value (Ent));
2715 -- An integer literal that was either in the source or created
2716 -- as a result of static evaluation.
2718 elsif Kind = N_Integer_Literal then
2721 -- A real literal for a fixed-point type. This must be the fixed-point
2722 -- case, either the literal is of a fixed-point type, or it is a bound
2723 -- of a fixed-point type, with type universal real. In either case we
2724 -- obtain the desired value from Corresponding_Integer_Value.
2726 elsif Kind = N_Real_Literal then
2727 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
2728 return Corresponding_Integer_Value (N);
2730 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
2732 elsif Kind = N_Attribute_Reference
2733 and then Attribute_Name (N) = Name_Null_Parameter
2737 -- Otherwise must be character literal
2740 pragma Assert (Kind = N_Character_Literal);
2743 -- Since Character literals of type Standard.Character don't
2744 -- have any defining character literals built for them, they
2745 -- do not have their Entity set, so just use their Char
2746 -- code. Otherwise for user-defined character literals use
2747 -- their Pos value as usual which is the same as the Rep value.
2750 return UI_From_Int (Int (Char_Literal_Value (N)));
2752 return Enumeration_Rep (Ent);
2761 function Expr_Value (N : Node_Id) return Uint is
2762 Kind : constant Node_Kind := Nkind (N);
2763 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
2768 -- If already in cache, then we know it's compile time known and
2769 -- we can return the value that was previously stored in the cache
2770 -- since compile time known values cannot change :-)
2772 if CV_Ent.N = N then
2776 -- Otherwise proceed to test value
2778 if Is_Entity_Name (N) then
2781 -- An enumeration literal that was either in the source or
2782 -- created as a result of static evaluation.
2784 if Ekind (Ent) = E_Enumeration_Literal then
2785 Val := Enumeration_Pos (Ent);
2787 -- A user defined static constant
2790 pragma Assert (Ekind (Ent) = E_Constant);
2791 Val := Expr_Value (Constant_Value (Ent));
2794 -- An integer literal that was either in the source or created
2795 -- as a result of static evaluation.
2797 elsif Kind = N_Integer_Literal then
2800 -- A real literal for a fixed-point type. This must be the fixed-point
2801 -- case, either the literal is of a fixed-point type, or it is a bound
2802 -- of a fixed-point type, with type universal real. In either case we
2803 -- obtain the desired value from Corresponding_Integer_Value.
2805 elsif Kind = N_Real_Literal then
2807 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
2808 Val := Corresponding_Integer_Value (N);
2810 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
2812 elsif Kind = N_Attribute_Reference
2813 and then Attribute_Name (N) = Name_Null_Parameter
2817 -- Otherwise must be character literal
2820 pragma Assert (Kind = N_Character_Literal);
2823 -- Since Character literals of type Standard.Character don't
2824 -- have any defining character literals built for them, they
2825 -- do not have their Entity set, so just use their Char
2826 -- code. Otherwise for user-defined character literals use
2827 -- their Pos value as usual.
2830 Val := UI_From_Int (Int (Char_Literal_Value (N)));
2832 Val := Enumeration_Pos (Ent);
2836 -- Come here with Val set to value to be returned, set cache
2847 function Expr_Value_E (N : Node_Id) return Entity_Id is
2848 Ent : constant Entity_Id := Entity (N);
2851 if Ekind (Ent) = E_Enumeration_Literal then
2854 pragma Assert (Ekind (Ent) = E_Constant);
2855 return Expr_Value_E (Constant_Value (Ent));
2863 function Expr_Value_R (N : Node_Id) return Ureal is
2864 Kind : constant Node_Kind := Nkind (N);
2869 if Kind = N_Real_Literal then
2872 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
2874 pragma Assert (Ekind (Ent) = E_Constant);
2875 return Expr_Value_R (Constant_Value (Ent));
2877 elsif Kind = N_Integer_Literal then
2878 return UR_From_Uint (Expr_Value (N));
2880 -- Strange case of VAX literals, which are at this stage transformed
2881 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
2882 -- Exp_Vfpt for further details.
2884 elsif Vax_Float (Etype (N))
2885 and then Nkind (N) = N_Unchecked_Type_Conversion
2887 Expr := Expression (N);
2889 if Nkind (Expr) = N_Function_Call
2890 and then Present (Parameter_Associations (Expr))
2892 Expr := First (Parameter_Associations (Expr));
2894 if Nkind (Expr) = N_Real_Literal then
2895 return Realval (Expr);
2899 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
2901 elsif Kind = N_Attribute_Reference
2902 and then Attribute_Name (N) = Name_Null_Parameter
2907 -- If we fall through, we have a node that cannot be interepreted
2908 -- as a compile time constant. That is definitely an error.
2910 raise Program_Error;
2917 function Expr_Value_S (N : Node_Id) return Node_Id is
2919 if Nkind (N) = N_String_Literal then
2922 pragma Assert (Ekind (Entity (N)) = E_Constant);
2923 return Expr_Value_S (Constant_Value (Entity (N)));
2927 --------------------------
2928 -- Flag_Non_Static_Expr --
2929 --------------------------
2931 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
2933 if Error_Posted (Expr) and then not All_Errors_Mode then
2936 Error_Msg_F (Msg, Expr);
2937 Why_Not_Static (Expr);
2939 end Flag_Non_Static_Expr;
2945 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
2946 Loc : constant Source_Ptr := Sloc (N);
2947 Typ : constant Entity_Id := Etype (N);
2950 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
2952 -- We now have the literal with the right value, both the actual type
2953 -- and the expected type of this literal are taken from the expression
2954 -- that was evaluated.
2957 Set_Is_Static_Expression (N, Static);
2966 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
2967 Loc : constant Source_Ptr := Sloc (N);
2968 Typ : Entity_Id := Etype (N);
2972 -- If we are folding a named number, retain the entity in the
2973 -- literal, for ASIS use.
2975 if Is_Entity_Name (N)
2976 and then Ekind (Entity (N)) = E_Named_Integer
2983 if Is_Private_Type (Typ) then
2984 Typ := Full_View (Typ);
2987 -- For a result of type integer, subsitute an N_Integer_Literal node
2988 -- for the result of the compile time evaluation of the expression.
2990 if Is_Integer_Type (Typ) then
2991 Rewrite (N, Make_Integer_Literal (Loc, Val));
2992 Set_Original_Entity (N, Ent);
2994 -- Otherwise we have an enumeration type, and we substitute either
2995 -- an N_Identifier or N_Character_Literal to represent the enumeration
2996 -- literal corresponding to the given value, which must always be in
2997 -- range, because appropriate tests have already been made for this.
2999 else pragma Assert (Is_Enumeration_Type (Typ));
3000 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
3003 -- We now have the literal with the right value, both the actual type
3004 -- and the expected type of this literal are taken from the expression
3005 -- that was evaluated.
3008 Set_Is_Static_Expression (N, Static);
3017 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
3018 Loc : constant Source_Ptr := Sloc (N);
3019 Typ : constant Entity_Id := Etype (N);
3023 -- If we are folding a named number, retain the entity in the
3024 -- literal, for ASIS use.
3026 if Is_Entity_Name (N)
3027 and then Ekind (Entity (N)) = E_Named_Real
3034 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
3035 Set_Original_Entity (N, Ent);
3037 -- Both the actual and expected type comes from the original expression
3040 Set_Is_Static_Expression (N, Static);
3049 function From_Bits (B : Bits; T : Entity_Id) return Uint is
3053 for J in 0 .. B'Last loop
3059 if Non_Binary_Modulus (T) then
3060 V := V mod Modulus (T);
3066 --------------------
3067 -- Get_String_Val --
3068 --------------------
3070 function Get_String_Val (N : Node_Id) return Node_Id is
3072 if Nkind (N) = N_String_Literal then
3075 elsif Nkind (N) = N_Character_Literal then
3079 pragma Assert (Is_Entity_Name (N));
3080 return Get_String_Val (Constant_Value (Entity (N)));
3088 procedure Initialize is
3090 CV_Cache := (others => (Node_High_Bound, Uint_0));
3093 --------------------
3094 -- In_Subrange_Of --
3095 --------------------
3097 function In_Subrange_Of
3100 Fixed_Int : Boolean := False)
3110 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
3113 -- Never in range if both types are not scalar. Don't know if this can
3114 -- actually happen, but just in case.
3116 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
3120 L1 := Type_Low_Bound (T1);
3121 H1 := Type_High_Bound (T1);
3123 L2 := Type_Low_Bound (T2);
3124 H2 := Type_High_Bound (T2);
3126 -- Check bounds to see if comparison possible at compile time
3128 if Compile_Time_Compare (L1, L2) in Compare_GE
3130 Compile_Time_Compare (H1, H2) in Compare_LE
3135 -- If bounds not comparable at compile time, then the bounds of T2
3136 -- must be compile time known or we cannot answer the query.
3138 if not Compile_Time_Known_Value (L2)
3139 or else not Compile_Time_Known_Value (H2)
3144 -- If the bounds of T1 are know at compile time then use these
3145 -- ones, otherwise use the bounds of the base type (which are of
3146 -- course always static).
3148 if not Compile_Time_Known_Value (L1) then
3149 L1 := Type_Low_Bound (Base_Type (T1));
3152 if not Compile_Time_Known_Value (H1) then
3153 H1 := Type_High_Bound (Base_Type (T1));
3156 -- Fixed point types should be considered as such only if
3157 -- flag Fixed_Int is set to False.
3159 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
3160 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
3161 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
3164 Expr_Value_R (L2) <= Expr_Value_R (L1)
3166 Expr_Value_R (H2) >= Expr_Value_R (H1);
3170 Expr_Value (L2) <= Expr_Value (L1)
3172 Expr_Value (H2) >= Expr_Value (H1);
3177 -- If any exception occurs, it means that we have some bug in the compiler
3178 -- possibly triggered by a previous error, or by some unforseen peculiar
3179 -- occurrence. However, this is only an optimization attempt, so there is
3180 -- really no point in crashing the compiler. Instead we just decide, too
3181 -- bad, we can't figure out the answer in this case after all.
3186 -- Debug flag K disables this behavior (useful for debugging)
3188 if Debug_Flag_K then
3199 function Is_In_Range
3202 Fixed_Int : Boolean := False;
3203 Int_Real : Boolean := False)
3210 -- Universal types have no range limits, so always in range.
3212 if Typ = Universal_Integer or else Typ = Universal_Real then
3215 -- Never in range if not scalar type. Don't know if this can
3216 -- actually happen, but our spec allows it, so we must check!
3218 elsif not Is_Scalar_Type (Typ) then
3221 -- Never in range unless we have a compile time known value.
3223 elsif not Compile_Time_Known_Value (N) then
3228 Lo : constant Node_Id := Type_Low_Bound (Typ);
3229 Hi : constant Node_Id := Type_High_Bound (Typ);
3230 LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
3231 UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
3234 -- Fixed point types should be considered as such only in
3235 -- flag Fixed_Int is set to False.
3237 if Is_Floating_Point_Type (Typ)
3238 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3241 Valr := Expr_Value_R (N);
3243 if LB_Known and then Valr >= Expr_Value_R (Lo)
3244 and then UB_Known and then Valr <= Expr_Value_R (Hi)
3252 Val := Expr_Value (N);
3254 if LB_Known and then Val >= Expr_Value (Lo)
3255 and then UB_Known and then Val <= Expr_Value (Hi)
3270 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3271 Typ : constant Entity_Id := Etype (Lo);
3274 if not Compile_Time_Known_Value (Lo)
3275 or else not Compile_Time_Known_Value (Hi)
3280 if Is_Discrete_Type (Typ) then
3281 return Expr_Value (Lo) > Expr_Value (Hi);
3284 pragma Assert (Is_Real_Type (Typ));
3285 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
3289 -----------------------------
3290 -- Is_OK_Static_Expression --
3291 -----------------------------
3293 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
3295 return Is_Static_Expression (N)
3296 and then not Raises_Constraint_Error (N);
3297 end Is_OK_Static_Expression;
3299 ------------------------
3300 -- Is_OK_Static_Range --
3301 ------------------------
3303 -- A static range is a range whose bounds are static expressions, or a
3304 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3305 -- We have already converted range attribute references, so we get the
3306 -- "or" part of this rule without needing a special test.
3308 function Is_OK_Static_Range (N : Node_Id) return Boolean is
3310 return Is_OK_Static_Expression (Low_Bound (N))
3311 and then Is_OK_Static_Expression (High_Bound (N));
3312 end Is_OK_Static_Range;
3314 --------------------------
3315 -- Is_OK_Static_Subtype --
3316 --------------------------
3318 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
3319 -- where neither bound raises constraint error when evaluated.
3321 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
3322 Base_T : constant Entity_Id := Base_Type (Typ);
3323 Anc_Subt : Entity_Id;
3326 -- First a quick check on the non static subtype flag. As described
3327 -- in further detail in Einfo, this flag is not decisive in all cases,
3328 -- but if it is set, then the subtype is definitely non-static.
3330 if Is_Non_Static_Subtype (Typ) then
3334 Anc_Subt := Ancestor_Subtype (Typ);
3336 if Anc_Subt = Empty then
3340 if Is_Generic_Type (Root_Type (Base_T))
3341 or else Is_Generic_Actual_Type (Base_T)
3347 elsif Is_String_Type (Typ) then
3349 Ekind (Typ) = E_String_Literal_Subtype
3351 (Is_OK_Static_Subtype (Component_Type (Typ))
3352 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
3356 elsif Is_Scalar_Type (Typ) then
3357 if Base_T = Typ then
3361 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so
3362 -- use Get_Type_Low,High_Bound.
3364 return Is_OK_Static_Subtype (Anc_Subt)
3365 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
3366 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
3369 -- Types other than string and scalar types are never static
3374 end Is_OK_Static_Subtype;
3376 ---------------------
3377 -- Is_Out_Of_Range --
3378 ---------------------
3380 function Is_Out_Of_Range
3383 Fixed_Int : Boolean := False;
3384 Int_Real : Boolean := False)
3391 -- Universal types have no range limits, so always in range.
3393 if Typ = Universal_Integer or else Typ = Universal_Real then
3396 -- Never out of range if not scalar type. Don't know if this can
3397 -- actually happen, but our spec allows it, so we must check!
3399 elsif not Is_Scalar_Type (Typ) then
3402 -- Never out of range if this is a generic type, since the bounds
3403 -- of generic types are junk. Note that if we only checked for
3404 -- static expressions (instead of compile time known values) below,
3405 -- we would not need this check, because values of a generic type
3406 -- can never be static, but they can be known at compile time.
3408 elsif Is_Generic_Type (Typ) then
3411 -- Never out of range unless we have a compile time known value
3413 elsif not Compile_Time_Known_Value (N) then
3418 Lo : constant Node_Id := Type_Low_Bound (Typ);
3419 Hi : constant Node_Id := Type_High_Bound (Typ);
3420 LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
3421 UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
3424 -- Real types (note that fixed-point types are not treated
3425 -- as being of a real type if the flag Fixed_Int is set,
3426 -- since in that case they are regarded as integer types).
3428 if Is_Floating_Point_Type (Typ)
3429 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3432 Valr := Expr_Value_R (N);
3434 if LB_Known and then Valr < Expr_Value_R (Lo) then
3437 elsif UB_Known and then Expr_Value_R (Hi) < Valr then
3445 Val := Expr_Value (N);
3447 if LB_Known and then Val < Expr_Value (Lo) then
3450 elsif UB_Known and then Expr_Value (Hi) < Val then
3459 end Is_Out_Of_Range;
3461 ---------------------
3462 -- Is_Static_Range --
3463 ---------------------
3465 -- A static range is a range whose bounds are static expressions, or a
3466 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3467 -- We have already converted range attribute references, so we get the
3468 -- "or" part of this rule without needing a special test.
3470 function Is_Static_Range (N : Node_Id) return Boolean is
3472 return Is_Static_Expression (Low_Bound (N))
3473 and then Is_Static_Expression (High_Bound (N));
3474 end Is_Static_Range;
3476 -----------------------
3477 -- Is_Static_Subtype --
3478 -----------------------
3480 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)).
3482 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
3483 Base_T : constant Entity_Id := Base_Type (Typ);
3484 Anc_Subt : Entity_Id;
3487 -- First a quick check on the non static subtype flag. As described
3488 -- in further detail in Einfo, this flag is not decisive in all cases,
3489 -- but if it is set, then the subtype is definitely non-static.
3491 if Is_Non_Static_Subtype (Typ) then
3495 Anc_Subt := Ancestor_Subtype (Typ);
3497 if Anc_Subt = Empty then
3501 if Is_Generic_Type (Root_Type (Base_T))
3502 or else Is_Generic_Actual_Type (Base_T)
3508 elsif Is_String_Type (Typ) then
3510 Ekind (Typ) = E_String_Literal_Subtype
3512 (Is_Static_Subtype (Component_Type (Typ))
3513 and then Is_Static_Subtype (Etype (First_Index (Typ))));
3517 elsif Is_Scalar_Type (Typ) then
3518 if Base_T = Typ then
3522 return Is_Static_Subtype (Anc_Subt)
3523 and then Is_Static_Expression (Type_Low_Bound (Typ))
3524 and then Is_Static_Expression (Type_High_Bound (Typ));
3527 -- Types other than string and scalar types are never static
3532 end Is_Static_Subtype;
3534 --------------------
3535 -- Not_Null_Range --
3536 --------------------
3538 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3539 Typ : constant Entity_Id := Etype (Lo);
3542 if not Compile_Time_Known_Value (Lo)
3543 or else not Compile_Time_Known_Value (Hi)
3548 if Is_Discrete_Type (Typ) then
3549 return Expr_Value (Lo) <= Expr_Value (Hi);
3552 pragma Assert (Is_Real_Type (Typ));
3554 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
3562 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
3564 -- We allow a maximum of 500,000 bits which seems a reasonable limit
3566 if Bits < 500_000 then
3570 Error_Msg_N ("static value too large, capacity exceeded", N);
3579 procedure Out_Of_Range (N : Node_Id) is
3581 -- If we have the static expression case, then this is an illegality
3582 -- in Ada 95 mode, except that in an instance, we never generate an
3583 -- error (if the error is legitimate, it was already diagnosed in
3584 -- the template). The expression to compute the length of a packed
3585 -- array is attached to the array type itself, and deserves a separate
3588 if Is_Static_Expression (N)
3589 and then not In_Instance
3590 and then not In_Inlined_Body
3591 and then Ada_Version >= Ada_95
3593 if Nkind (Parent (N)) = N_Defining_Identifier
3594 and then Is_Array_Type (Parent (N))
3595 and then Present (Packed_Array_Type (Parent (N)))
3596 and then Present (First_Rep_Item (Parent (N)))
3599 ("length of packed array must not exceed Integer''Last",
3600 First_Rep_Item (Parent (N)));
3601 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
3604 Apply_Compile_Time_Constraint_Error
3605 (N, "value not in range of}", CE_Range_Check_Failed);
3608 -- Here we generate a warning for the Ada 83 case, or when we are
3609 -- in an instance, or when we have a non-static expression case.
3612 Apply_Compile_Time_Constraint_Error
3613 (N, "value not in range of}?", CE_Range_Check_Failed);
3617 -------------------------
3618 -- Rewrite_In_Raise_CE --
3619 -------------------------
3621 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
3622 Typ : constant Entity_Id := Etype (N);
3625 -- If we want to raise CE in the condition of a raise_CE node
3626 -- we may as well get rid of the condition
3628 if Present (Parent (N))
3629 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
3631 Set_Condition (Parent (N), Empty);
3633 -- If the expression raising CE is a N_Raise_CE node, we can use
3634 -- that one. We just preserve the type of the context
3636 elsif Nkind (Exp) = N_Raise_Constraint_Error then
3640 -- We have to build an explicit raise_ce node
3644 Make_Raise_Constraint_Error (Sloc (Exp),
3645 Reason => CE_Range_Check_Failed));
3646 Set_Raises_Constraint_Error (N);
3649 end Rewrite_In_Raise_CE;
3651 ---------------------
3652 -- String_Type_Len --
3653 ---------------------
3655 function String_Type_Len (Stype : Entity_Id) return Uint is
3656 NT : constant Entity_Id := Etype (First_Index (Stype));
3660 if Is_OK_Static_Subtype (NT) then
3663 T := Base_Type (NT);
3666 return Expr_Value (Type_High_Bound (T)) -
3667 Expr_Value (Type_Low_Bound (T)) + 1;
3668 end String_Type_Len;
3670 ------------------------------------
3671 -- Subtypes_Statically_Compatible --
3672 ------------------------------------
3674 function Subtypes_Statically_Compatible
3680 if Is_Scalar_Type (T1) then
3682 -- Definitely compatible if we match
3684 if Subtypes_Statically_Match (T1, T2) then
3687 -- If either subtype is nonstatic then they're not compatible
3689 elsif not Is_Static_Subtype (T1)
3690 or else not Is_Static_Subtype (T2)
3694 -- If either type has constraint error bounds, then consider that
3695 -- they match to avoid junk cascaded errors here.
3697 elsif not Is_OK_Static_Subtype (T1)
3698 or else not Is_OK_Static_Subtype (T2)
3702 -- Base types must match, but we don't check that (should
3703 -- we???) but we do at least check that both types are
3704 -- real, or both types are not real.
3706 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
3709 -- Here we check the bounds
3713 LB1 : constant Node_Id := Type_Low_Bound (T1);
3714 HB1 : constant Node_Id := Type_High_Bound (T1);
3715 LB2 : constant Node_Id := Type_Low_Bound (T2);
3716 HB2 : constant Node_Id := Type_High_Bound (T2);
3719 if Is_Real_Type (T1) then
3721 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
3723 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
3725 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
3729 (Expr_Value (LB1) > Expr_Value (HB1))
3731 (Expr_Value (LB2) <= Expr_Value (LB1)
3733 Expr_Value (HB1) <= Expr_Value (HB2));
3738 elsif Is_Access_Type (T1) then
3739 return not Is_Constrained (T2)
3740 or else Subtypes_Statically_Match
3741 (Designated_Type (T1), Designated_Type (T2));
3744 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
3745 or else Subtypes_Statically_Match (T1, T2);
3747 end Subtypes_Statically_Compatible;
3749 -------------------------------
3750 -- Subtypes_Statically_Match --
3751 -------------------------------
3753 -- Subtypes statically match if they have statically matching constraints
3754 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
3755 -- they are the same identical constraint, or if they are static and the
3756 -- values match (RM 4.9.1(1)).
3758 function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
3760 -- A type always statically matches itself
3767 elsif Is_Scalar_Type (T1) then
3769 -- Base types must be the same
3771 if Base_Type (T1) /= Base_Type (T2) then
3775 -- A constrained numeric subtype never matches an unconstrained
3776 -- subtype, i.e. both types must be constrained or unconstrained.
3778 -- To understand the requirement for this test, see RM 4.9.1(1).
3779 -- As is made clear in RM 3.5.4(11), type Integer, for example
3780 -- is a constrained subtype with constraint bounds matching the
3781 -- bounds of its corresponding uncontrained base type. In this
3782 -- situation, Integer and Integer'Base do not statically match,
3783 -- even though they have the same bounds.
3785 -- We only apply this test to types in Standard and types that
3786 -- appear in user programs. That way, we do not have to be
3787 -- too careful about setting Is_Constrained right for itypes.
3789 if Is_Numeric_Type (T1)
3790 and then (Is_Constrained (T1) /= Is_Constrained (T2))
3791 and then (Scope (T1) = Standard_Standard
3792 or else Comes_From_Source (T1))
3793 and then (Scope (T2) = Standard_Standard
3794 or else Comes_From_Source (T2))
3799 -- If there was an error in either range, then just assume
3800 -- the types statically match to avoid further junk errors
3802 if Error_Posted (Scalar_Range (T1))
3804 Error_Posted (Scalar_Range (T2))
3809 -- Otherwise both types have bound that can be compared
3812 LB1 : constant Node_Id := Type_Low_Bound (T1);
3813 HB1 : constant Node_Id := Type_High_Bound (T1);
3814 LB2 : constant Node_Id := Type_Low_Bound (T2);
3815 HB2 : constant Node_Id := Type_High_Bound (T2);
3818 -- If the bounds are the same tree node, then match
3820 if LB1 = LB2 and then HB1 = HB2 then
3823 -- Otherwise bounds must be static and identical value
3826 if not Is_Static_Subtype (T1)
3827 or else not Is_Static_Subtype (T2)
3831 -- If either type has constraint error bounds, then say
3832 -- that they match to avoid junk cascaded errors here.
3834 elsif not Is_OK_Static_Subtype (T1)
3835 or else not Is_OK_Static_Subtype (T2)
3839 elsif Is_Real_Type (T1) then
3841 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
3843 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
3847 Expr_Value (LB1) = Expr_Value (LB2)
3849 Expr_Value (HB1) = Expr_Value (HB2);
3854 -- Type with discriminants
3856 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
3857 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
3862 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
3863 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
3865 DA1 : Elmt_Id := First_Elmt (DL1);
3866 DA2 : Elmt_Id := First_Elmt (DL2);
3872 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
3876 while Present (DA1) loop
3878 Expr1 : constant Node_Id := Node (DA1);
3879 Expr2 : constant Node_Id := Node (DA2);
3882 if not Is_Static_Expression (Expr1)
3883 or else not Is_Static_Expression (Expr2)
3887 -- If either expression raised a constraint error,
3888 -- consider the expressions as matching, since this
3889 -- helps to prevent cascading errors.
3891 elsif Raises_Constraint_Error (Expr1)
3892 or else Raises_Constraint_Error (Expr2)
3896 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
3908 -- A definite type does not match an indefinite or classwide type.
3911 Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
3917 elsif Is_Array_Type (T1) then
3919 -- If either subtype is unconstrained then both must be,
3920 -- and if both are unconstrained then no further checking
3923 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
3924 return not (Is_Constrained (T1) or else Is_Constrained (T2));
3927 -- Both subtypes are constrained, so check that the index
3928 -- subtypes statically match.
3931 Index1 : Node_Id := First_Index (T1);
3932 Index2 : Node_Id := First_Index (T2);
3935 while Present (Index1) loop
3937 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
3942 Next_Index (Index1);
3943 Next_Index (Index2);
3949 elsif Is_Access_Type (T1) then
3950 return Subtypes_Statically_Match
3951 (Designated_Type (T1),
3952 Designated_Type (T2));
3954 -- All other types definitely match
3959 end Subtypes_Statically_Match;
3965 function Test (Cond : Boolean) return Uint is
3974 ---------------------------------
3975 -- Test_Expression_Is_Foldable --
3976 ---------------------------------
3980 procedure Test_Expression_Is_Foldable
3989 -- If operand is Any_Type, just propagate to result and do not
3990 -- try to fold, this prevents cascaded errors.
3992 if Etype (Op1) = Any_Type then
3993 Set_Etype (N, Any_Type);
3997 -- If operand raises constraint error, then replace node N with the
3998 -- raise constraint error node, and we are obviously not foldable.
3999 -- Note that this replacement inherits the Is_Static_Expression flag
4000 -- from the operand.
4002 elsif Raises_Constraint_Error (Op1) then
4003 Rewrite_In_Raise_CE (N, Op1);
4007 -- If the operand is not static, then the result is not static, and
4008 -- all we have to do is to check the operand since it is now known
4009 -- to appear in a non-static context.
4011 elsif not Is_Static_Expression (Op1) then
4012 Check_Non_Static_Context (Op1);
4013 Fold := Compile_Time_Known_Value (Op1);
4016 -- An expression of a formal modular type is not foldable because
4017 -- the modulus is unknown.
4019 elsif Is_Modular_Integer_Type (Etype (Op1))
4020 and then Is_Generic_Type (Etype (Op1))
4022 Check_Non_Static_Context (Op1);
4026 -- Here we have the case of an operand whose type is OK, which is
4027 -- static, and which does not raise constraint error, we can fold.
4030 Set_Is_Static_Expression (N);
4034 end Test_Expression_Is_Foldable;
4038 procedure Test_Expression_Is_Foldable
4045 Rstat : constant Boolean := Is_Static_Expression (Op1)
4046 and then Is_Static_Expression (Op2);
4051 -- If either operand is Any_Type, just propagate to result and
4052 -- do not try to fold, this prevents cascaded errors.
4054 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
4055 Set_Etype (N, Any_Type);
4059 -- If left operand raises constraint error, then replace node N with
4060 -- the raise constraint error node, and we are obviously not foldable.
4061 -- Is_Static_Expression is set from the two operands in the normal way,
4062 -- and we check the right operand if it is in a non-static context.
4064 elsif Raises_Constraint_Error (Op1) then
4066 Check_Non_Static_Context (Op2);
4069 Rewrite_In_Raise_CE (N, Op1);
4070 Set_Is_Static_Expression (N, Rstat);
4074 -- Similar processing for the case of the right operand. Note that
4075 -- we don't use this routine for the short-circuit case, so we do
4076 -- not have to worry about that special case here.
4078 elsif Raises_Constraint_Error (Op2) then
4080 Check_Non_Static_Context (Op1);
4083 Rewrite_In_Raise_CE (N, Op2);
4084 Set_Is_Static_Expression (N, Rstat);
4088 -- Exclude expressions of a generic modular type, as above.
4090 elsif Is_Modular_Integer_Type (Etype (Op1))
4091 and then Is_Generic_Type (Etype (Op1))
4093 Check_Non_Static_Context (Op1);
4097 -- If result is not static, then check non-static contexts on operands
4098 -- since one of them may be static and the other one may not be static
4100 elsif not Rstat then
4101 Check_Non_Static_Context (Op1);
4102 Check_Non_Static_Context (Op2);
4103 Fold := Compile_Time_Known_Value (Op1)
4104 and then Compile_Time_Known_Value (Op2);
4107 -- Else result is static and foldable. Both operands are static,
4108 -- and neither raises constraint error, so we can definitely fold.
4111 Set_Is_Static_Expression (N);
4116 end Test_Expression_Is_Foldable;
4122 procedure To_Bits (U : Uint; B : out Bits) is
4124 for J in 0 .. B'Last loop
4125 B (J) := (U / (2 ** J)) mod 2 /= 0;
4129 --------------------
4130 -- Why_Not_Static --
4131 --------------------
4133 procedure Why_Not_Static (Expr : Node_Id) is
4134 N : constant Node_Id := Original_Node (Expr);
4138 procedure Why_Not_Static_List (L : List_Id);
4139 -- A version that can be called on a list of expressions. Finds
4140 -- all non-static violations in any element of the list.
4142 -------------------------
4143 -- Why_Not_Static_List --
4144 -------------------------
4146 procedure Why_Not_Static_List (L : List_Id) is
4150 if Is_Non_Empty_List (L) then
4152 while Present (N) loop
4157 end Why_Not_Static_List;
4159 -- Start of processing for Why_Not_Static
4162 -- If in ACATS mode (debug flag 2), then suppress all these
4163 -- messages, this avoids massive updates to the ACATS base line.
4165 if Debug_Flag_2 then
4169 -- Ignore call on error or empty node
4171 if No (Expr) or else Nkind (Expr) = N_Error then
4175 -- Preprocessing for sub expressions
4177 if Nkind (Expr) in N_Subexpr then
4179 -- Nothing to do if expression is static
4181 if Is_OK_Static_Expression (Expr) then
4185 -- Test for constraint error raised
4187 if Raises_Constraint_Error (Expr) then
4189 ("expression raises exception, cannot be static " &
4190 "('R'M 4.9(34))!", N);
4194 -- If no type, then something is pretty wrong, so ignore
4196 Typ := Etype (Expr);
4202 -- Type must be scalar or string type
4204 if not Is_Scalar_Type (Typ)
4205 and then not Is_String_Type (Typ)
4208 ("static expression must have scalar or string type " &
4209 "('R'M 4.9(2))!", N);
4214 -- If we got through those checks, test particular node kind
4217 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
4220 if Is_Named_Number (E) then
4223 elsif Ekind (E) = E_Constant then
4224 if not Is_Static_Expression (Constant_Value (E)) then
4226 ("& is not a static constant ('R'M 4.9(5))!", N, E);
4231 ("& is not static constant or named number " &
4232 "('R'M 4.9(5))!", N, E);
4235 when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
4236 if Nkind (N) in N_Op_Shift then
4238 ("shift functions are never static ('R'M 4.9(6,18))!", N);
4241 Why_Not_Static (Left_Opnd (N));
4242 Why_Not_Static (Right_Opnd (N));
4246 Why_Not_Static (Right_Opnd (N));
4248 when N_Attribute_Reference =>
4249 Why_Not_Static_List (Expressions (N));
4251 E := Etype (Prefix (N));
4253 if E = Standard_Void_Type then
4257 -- Special case non-scalar'Size since this is a common error
4259 if Attribute_Name (N) = Name_Size then
4261 ("size attribute is only static for scalar type " &
4262 "('R'M 4.9(7,8))", N);
4266 elsif Is_Array_Type (E) then
4267 if Attribute_Name (N) /= Name_First
4269 Attribute_Name (N) /= Name_Last
4271 Attribute_Name (N) /= Name_Length
4274 ("static array attribute must be Length, First, or Last " &
4275 "('R'M 4.9(8))!", N);
4277 -- Since we know the expression is not-static (we already
4278 -- tested for this, must mean array is not static).
4282 ("prefix is non-static array ('R'M 4.9(8))!", Prefix (N));
4287 -- Special case generic types, since again this is a common
4288 -- source of confusion.
4290 elsif Is_Generic_Actual_Type (E)
4295 ("attribute of generic type is never static " &
4296 "('R'M 4.9(7,8))!", N);
4298 elsif Is_Static_Subtype (E) then
4301 elsif Is_Scalar_Type (E) then
4303 ("prefix type for attribute is not static scalar subtype " &
4304 "('R'M 4.9(7))!", N);
4308 ("static attribute must apply to array/scalar type " &
4309 "('R'M 4.9(7,8))!", N);
4312 when N_String_Literal =>
4314 ("subtype of string literal is non-static ('R'M 4.9(4))!", N);
4316 when N_Explicit_Dereference =>
4318 ("explicit dereference is never static ('R'M 4.9)!", N);
4320 when N_Function_Call =>
4321 Why_Not_Static_List (Parameter_Associations (N));
4322 Error_Msg_N ("non-static function call ('R'M 4.9(6,18))!", N);
4324 when N_Parameter_Association =>
4325 Why_Not_Static (Explicit_Actual_Parameter (N));
4327 when N_Indexed_Component =>
4329 ("indexed component is never static ('R'M 4.9)!", N);
4331 when N_Procedure_Call_Statement =>
4333 ("procedure call is never static ('R'M 4.9)!", N);
4335 when N_Qualified_Expression =>
4336 Why_Not_Static (Expression (N));
4338 when N_Aggregate | N_Extension_Aggregate =>
4340 ("an aggregate is never static ('R'M 4.9)!", N);
4343 Why_Not_Static (Low_Bound (N));
4344 Why_Not_Static (High_Bound (N));
4346 when N_Range_Constraint =>
4347 Why_Not_Static (Range_Expression (N));
4349 when N_Subtype_Indication =>
4350 Why_Not_Static (Constraint (N));
4352 when N_Selected_Component =>
4354 ("selected component is never static ('R'M 4.9)!", N);
4358 ("slice is never static ('R'M 4.9)!", N);
4360 when N_Type_Conversion =>
4361 Why_Not_Static (Expression (N));
4363 if not Is_Scalar_Type (Etype (Prefix (N)))
4364 or else not Is_Static_Subtype (Etype (Prefix (N)))
4367 ("static conversion requires static scalar subtype result " &
4368 "('R'M 4.9(9))!", N);
4371 when N_Unchecked_Type_Conversion =>
4373 ("unchecked type conversion is never static ('R'M 4.9)!", N);