1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Eval_Fat; use Eval_Fat;
33 with Exp_Util; use Exp_Util;
35 with Namet; use Namet;
36 with Nmake; use Nmake;
37 with Nlists; use Nlists;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Cat; use Sem_Cat;
42 with Sem_Ch6; use Sem_Ch6;
43 with Sem_Ch8; use Sem_Ch8;
44 with Sem_Res; use Sem_Res;
45 with Sem_Util; use Sem_Util;
46 with Sem_Type; use Sem_Type;
47 with Sem_Warn; use Sem_Warn;
48 with Sinfo; use Sinfo;
49 with Snames; use Snames;
50 with Stand; use Stand;
51 with Stringt; use Stringt;
52 with Tbuild; use Tbuild;
54 package body Sem_Eval is
56 -----------------------------------------
57 -- Handling of Compile Time Evaluation --
58 -----------------------------------------
60 -- The compile time evaluation of expressions is distributed over several
61 -- Eval_xxx procedures. These procedures are called immediately after
62 -- a subexpression is resolved and is therefore accomplished in a bottom
63 -- up fashion. The flags are synthesized using the following approach.
65 -- Is_Static_Expression is determined by following the detailed rules
66 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
67 -- flag of the operands in many cases.
69 -- Raises_Constraint_Error is set if any of the operands have the flag
70 -- set or if an attempt to compute the value of the current expression
71 -- results in detection of a runtime constraint error.
73 -- As described in the spec, the requirement is that Is_Static_Expression
74 -- be accurately set, and in addition for nodes for which this flag is set,
75 -- Raises_Constraint_Error must also be set. Furthermore a node which has
76 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
77 -- requirement is that the expression value must be precomputed, and the
78 -- node is either a literal, or the name of a constant entity whose value
79 -- is a static expression.
81 -- The general approach is as follows. First compute Is_Static_Expression.
82 -- If the node is not static, then the flag is left off in the node and
83 -- we are all done. Otherwise for a static node, we test if any of the
84 -- operands will raise constraint error, and if so, propagate the flag
85 -- Raises_Constraint_Error to the result node and we are done (since the
86 -- error was already posted at a lower level).
88 -- For the case of a static node whose operands do not raise constraint
89 -- error, we attempt to evaluate the node. If this evaluation succeeds,
90 -- then the node is replaced by the result of this computation. If the
91 -- evaluation raises constraint error, then we rewrite the node with
92 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
93 -- to post appropriate error messages.
99 type Bits is array (Nat range <>) of Boolean;
100 -- Used to convert unsigned (modular) values for folding logical ops
102 -- The following definitions are used to maintain a cache of nodes that
103 -- have compile time known values. The cache is maintained only for
104 -- discrete types (the most common case), and is populated by calls to
105 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
106 -- since it is possible for the status to change (in particular it is
107 -- possible for a node to get replaced by a constraint error node).
109 CV_Bits : constant := 5;
110 -- Number of low order bits of Node_Id value used to reference entries
111 -- in the cache table.
113 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
114 -- Size of cache for compile time values
116 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
118 type CV_Entry is record
123 type CV_Cache_Array is array (CV_Range) of CV_Entry;
125 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
126 -- This is the actual cache, with entries consisting of node/value pairs,
127 -- and the impossible value Node_High_Bound used for unset entries.
129 -----------------------
130 -- Local Subprograms --
131 -----------------------
133 function From_Bits (B : Bits; T : Entity_Id) return Uint;
134 -- Converts a bit string of length B'Length to a Uint value to be used
135 -- for a target of type T, which is a modular type. This procedure
136 -- includes the necessary reduction by the modulus in the case of a
137 -- non-binary modulus (for a binary modulus, the bit string is the
138 -- right length any way so all is well).
140 function Get_String_Val (N : Node_Id) return Node_Id;
141 -- Given a tree node for a folded string or character value, returns
142 -- the corresponding string literal or character literal (one of the
143 -- two must be available, or the operand would not have been marked
144 -- as foldable in the earlier analysis of the operation).
146 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
147 -- Bits represents the number of bits in an integer value to be computed
148 -- (but the value has not been computed yet). If this value in Bits is
149 -- reasonable, a result of True is returned, with the implication that
150 -- the caller should go ahead and complete the calculation. If the value
151 -- in Bits is unreasonably large, then an error is posted on node N, and
152 -- False is returned (and the caller skips the proposed calculation).
154 procedure Out_Of_Range (N : Node_Id);
155 -- This procedure is called if it is determined that node N, which
156 -- appears in a non-static context, is a compile time known value
157 -- which is outside its range, i.e. the range of Etype. This is used
158 -- in contexts where this is an illegality if N is static, and should
159 -- generate a warning otherwise.
161 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
162 -- N and Exp are nodes representing an expression, Exp is known
163 -- to raise CE. N is rewritten in term of Exp in the optimal way.
165 function String_Type_Len (Stype : Entity_Id) return Uint;
166 -- Given a string type, determines the length of the index type, or,
167 -- if this index type is non-static, the length of the base type of
168 -- this index type. Note that if the string type is itself static,
169 -- then the index type is static, so the second case applies only
170 -- if the string type passed is non-static.
172 function Test (Cond : Boolean) return Uint;
173 pragma Inline (Test);
174 -- This function simply returns the appropriate Boolean'Pos value
175 -- corresponding to the value of Cond as a universal integer. It is
176 -- used for producing the result of the static evaluation of the
179 procedure Test_Expression_Is_Foldable
184 -- Tests to see if expression N whose single operand is Op1 is foldable,
185 -- i.e. the operand value is known at compile time. If the operation is
186 -- foldable, then Fold is True on return, and Stat indicates whether
187 -- the result is static (i.e. both operands were static). Note that it
188 -- is quite possible for Fold to be True, and Stat to be False, since
189 -- there are cases in which we know the value of an operand even though
190 -- it is not technically static (e.g. the static lower bound of a range
191 -- whose upper bound is non-static).
193 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes a
194 -- call to Check_Non_Static_Context on the operand. If Fold is False on
195 -- return, then all processing is complete, and the caller should
196 -- return, since there is nothing else to do.
198 procedure Test_Expression_Is_Foldable
204 -- Same processing, except applies to an expression N with two operands
207 procedure To_Bits (U : Uint; B : out Bits);
208 -- Converts a Uint value to a bit string of length B'Length
210 ------------------------------
211 -- Check_Non_Static_Context --
212 ------------------------------
214 procedure Check_Non_Static_Context (N : Node_Id) is
215 T : constant Entity_Id := Etype (N);
216 Checks_On : constant Boolean :=
217 not Index_Checks_Suppressed (T)
218 and not Range_Checks_Suppressed (T);
221 -- Ignore cases of non-scalar types or error types
223 if T = Any_Type or else not Is_Scalar_Type (T) then
227 -- At this stage we have a scalar type. If we have an expression
228 -- that raises CE, then we already issued a warning or error msg
229 -- so there is nothing more to be done in this routine.
231 if Raises_Constraint_Error (N) then
235 -- Now we have a scalar type which is not marked as raising a
236 -- constraint error exception. The main purpose of this routine
237 -- is to deal with static expressions appearing in a non-static
238 -- context. That means that if we do not have a static expression
239 -- then there is not much to do. The one case that we deal with
240 -- here is that if we have a floating-point value that is out of
241 -- range, then we post a warning that an infinity will result.
243 if not Is_Static_Expression (N) then
244 if Is_Floating_Point_Type (T)
245 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
248 ("?float value out of range, infinity will be generated", N);
254 -- Here we have the case of outer level static expression of
255 -- scalar type, where the processing of this procedure is needed.
257 -- For real types, this is where we convert the value to a machine
258 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should
259 -- only need to do this if the parent is a constant declaration,
260 -- since in other cases, gigi should do the necessary conversion
261 -- correctly, but experimentation shows that this is not the case
262 -- on all machines, in particular if we do not convert all literals
263 -- to machine values in non-static contexts, then ACVC test C490001
264 -- fails on Sparc/Solaris and SGI/Irix.
266 if Nkind (N) = N_Real_Literal
267 and then not Is_Machine_Number (N)
268 and then not Is_Generic_Type (Etype (N))
269 and then Etype (N) /= Universal_Real
271 -- Check that value is in bounds before converting to machine
272 -- number, so as not to lose case where value overflows in the
273 -- least significant bit or less. See B490001.
275 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
280 -- Note: we have to copy the node, to avoid problems with conformance
281 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
283 Rewrite (N, New_Copy (N));
285 if not Is_Floating_Point_Type (T) then
287 (N, Corresponding_Integer_Value (N) * Small_Value (T));
289 elsif not UR_Is_Zero (Realval (N)) then
291 -- Note: even though RM 4.9(38) specifies biased rounding,
292 -- this has been modified by AI-100 in order to prevent
293 -- confusing differences in rounding between static and
294 -- non-static expressions. AI-100 specifies that the effect
295 -- of such rounding is implementation dependent, and in GNAT
296 -- we round to nearest even to match the run-time behavior.
299 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
302 Set_Is_Machine_Number (N);
305 -- Check for out of range universal integer. This is a non-static
306 -- context, so the integer value must be in range of the runtime
307 -- representation of universal integers.
309 -- We do this only within an expression, because that is the only
310 -- case in which non-static universal integer values can occur, and
311 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
312 -- called in contexts like the expression of a number declaration where
313 -- we certainly want to allow out of range values.
315 if Etype (N) = Universal_Integer
316 and then Nkind (N) = N_Integer_Literal
317 and then Nkind (Parent (N)) in N_Subexpr
319 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
321 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
323 Apply_Compile_Time_Constraint_Error
324 (N, "non-static universal integer value out of range?",
325 CE_Range_Check_Failed);
327 -- Check out of range of base type
329 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
332 -- Give warning if outside subtype (where one or both of the bounds of
333 -- the subtype is static). This warning is omitted if the expression
334 -- appears in a range that could be null (warnings are handled elsewhere
337 elsif T /= Base_Type (T)
338 and then Nkind (Parent (N)) /= N_Range
340 if Is_In_Range (N, T, Assume_Valid => True) then
343 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
344 Apply_Compile_Time_Constraint_Error
345 (N, "value not in range of}?", CE_Range_Check_Failed);
348 Enable_Range_Check (N);
351 Set_Do_Range_Check (N, False);
354 end Check_Non_Static_Context;
356 ---------------------------------
357 -- Check_String_Literal_Length --
358 ---------------------------------
360 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
362 if not Raises_Constraint_Error (N)
363 and then Is_Constrained (Ttype)
366 UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
368 Apply_Compile_Time_Constraint_Error
369 (N, "string length wrong for}?",
370 CE_Length_Check_Failed,
375 end Check_String_Literal_Length;
377 --------------------------
378 -- Compile_Time_Compare --
379 --------------------------
381 function Compile_Time_Compare
383 Assume_Valid : Boolean;
384 Rec : Boolean := False) return Compare_Result
386 Ltyp : Entity_Id := Etype (L);
387 Rtyp : Entity_Id := Etype (R);
388 -- These get reset to the base type for the case of entities where
389 -- Is_Known_Valid is not set. This takes care of handling possible
390 -- invalid representations using the value of the base type, in
391 -- accordance with RM 13.9.1(10).
393 procedure Compare_Decompose
397 -- This procedure decomposes the node N into an expression node and a
398 -- signed offset, so that the value of N is equal to the value of R plus
399 -- the value V (which may be negative). If no such decomposition is
400 -- possible, then on return R is a copy of N, and V is set to zero.
402 function Compare_Fixup (N : Node_Id) return Node_Id;
403 -- This function deals with replacing 'Last and 'First references with
404 -- their corresponding type bounds, which we then can compare. The
405 -- argument is the original node, the result is the identity, unless we
406 -- have a 'Last/'First reference in which case the value returned is the
407 -- appropriate type bound.
409 function Is_Same_Value (L, R : Node_Id) return Boolean;
410 -- Returns True iff L and R represent expressions that definitely
411 -- have identical (but not necessarily compile time known) values
412 -- Indeed the caller is expected to have already dealt with the
413 -- cases of compile time known values, so these are not tested here.
415 -----------------------
416 -- Compare_Decompose --
417 -----------------------
419 procedure Compare_Decompose
425 if Nkind (N) = N_Op_Add
426 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
429 V := Intval (Right_Opnd (N));
432 elsif Nkind (N) = N_Op_Subtract
433 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
436 V := UI_Negate (Intval (Right_Opnd (N)));
439 elsif Nkind (N) = N_Attribute_Reference then
440 if Attribute_Name (N) = Name_Succ then
441 R := First (Expressions (N));
445 elsif Attribute_Name (N) = Name_Pred then
446 R := First (Expressions (N));
454 end Compare_Decompose;
460 function Compare_Fixup (N : Node_Id) return Node_Id is
466 if Nkind (N) = N_Attribute_Reference
467 and then (Attribute_Name (N) = Name_First
469 Attribute_Name (N) = Name_Last)
471 Xtyp := Etype (Prefix (N));
473 -- If we have no type, then just abandon the attempt to do
474 -- a fixup, this is probably the result of some other error.
480 -- Dereference an access type
482 if Is_Access_Type (Xtyp) then
483 Xtyp := Designated_Type (Xtyp);
486 -- If we don't have an array type at this stage, something
487 -- is peculiar, e.g. another error, and we abandon the attempt
490 if not Is_Array_Type (Xtyp) then
494 -- Ignore unconstrained array, since bounds are not meaningful
496 if not Is_Constrained (Xtyp) then
500 if Ekind (Xtyp) = E_String_Literal_Subtype then
501 if Attribute_Name (N) = Name_First then
502 return String_Literal_Low_Bound (Xtyp);
504 else -- Attribute_Name (N) = Name_Last
505 return Make_Integer_Literal (Sloc (N),
506 Intval => Intval (String_Literal_Low_Bound (Xtyp))
507 + String_Literal_Length (Xtyp));
511 -- Find correct index type
513 Indx := First_Index (Xtyp);
515 if Present (Expressions (N)) then
516 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
518 for J in 2 .. Subs loop
519 Indx := Next_Index (Indx);
523 Xtyp := Etype (Indx);
525 if Attribute_Name (N) = Name_First then
526 return Type_Low_Bound (Xtyp);
528 else -- Attribute_Name (N) = Name_Last
529 return Type_High_Bound (Xtyp);
540 function Is_Same_Value (L, R : Node_Id) return Boolean is
541 Lf : constant Node_Id := Compare_Fixup (L);
542 Rf : constant Node_Id := Compare_Fixup (R);
544 function Is_Same_Subscript (L, R : List_Id) return Boolean;
545 -- L, R are the Expressions values from two attribute nodes
546 -- for First or Last attributes. Either may be set to No_List
547 -- if no expressions are present (indicating subscript 1).
548 -- The result is True if both expressions represent the same
549 -- subscript (note that one case is where one subscript is
550 -- missing and the other is explicitly set to 1).
552 -----------------------
553 -- Is_Same_Subscript --
554 -----------------------
556 function Is_Same_Subscript (L, R : List_Id) return Boolean is
562 return Expr_Value (First (R)) = Uint_1;
567 return Expr_Value (First (L)) = Uint_1;
569 return Expr_Value (First (L)) = Expr_Value (First (R));
572 end Is_Same_Subscript;
574 -- Start of processing for Is_Same_Value
577 -- Values are the same if they refer to the same entity and the
578 -- entity is non-volatile. This does not however apply to Float
579 -- types, since we may have two NaN values and they should never
582 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
583 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
584 and then Entity (Lf) = Entity (Rf)
585 and then Present (Entity (Lf))
586 and then not Is_Floating_Point_Type (Etype (L))
587 and then not Is_Volatile_Reference (L)
588 and then not Is_Volatile_Reference (R)
592 -- Or if they are compile time known and identical
594 elsif Compile_Time_Known_Value (Lf)
596 Compile_Time_Known_Value (Rf)
597 and then Expr_Value (Lf) = Expr_Value (Rf)
601 -- False if Nkind of the two nodes is different for remaining cases
603 elsif Nkind (Lf) /= Nkind (Rf) then
606 -- True if both 'First or 'Last values applying to the same entity
607 -- (first and last don't change even if value does). Note that we
608 -- need this even with the calls to Compare_Fixup, to handle the
609 -- case of unconstrained array attributes where Compare_Fixup
610 -- cannot find useful bounds.
612 elsif Nkind (Lf) = N_Attribute_Reference
613 and then Attribute_Name (Lf) = Attribute_Name (Rf)
614 and then (Attribute_Name (Lf) = Name_First
616 Attribute_Name (Lf) = Name_Last)
617 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
618 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
619 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
620 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
624 -- True if the same selected component from the same record
626 elsif Nkind (Lf) = N_Selected_Component
627 and then Selector_Name (Lf) = Selector_Name (Rf)
628 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
632 -- True if the same unary operator applied to the same operand
634 elsif Nkind (Lf) in N_Unary_Op
635 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
639 -- True if the same binary operator applied to the same operands
641 elsif Nkind (Lf) in N_Binary_Op
642 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
643 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
647 -- All other cases, we can't tell, so return False
654 -- Start of processing for Compile_Time_Compare
657 -- If either operand could raise constraint error, then we cannot
658 -- know the result at compile time (since CE may be raised!)
660 if not (Cannot_Raise_Constraint_Error (L)
662 Cannot_Raise_Constraint_Error (R))
667 -- Identical operands are most certainly equal
672 -- If expressions have no types, then do not attempt to determine
673 -- if they are the same, since something funny is going on. One
674 -- case in which this happens is during generic template analysis,
675 -- when bounds are not fully analyzed.
677 elsif No (Ltyp) or else No (Rtyp) then
680 -- We only attempt compile time analysis for scalar values, and
681 -- not for packed arrays represented as modular types, where the
682 -- semantics of comparison is quite different.
684 elsif not Is_Scalar_Type (Ltyp)
685 or else Is_Packed_Array_Type (Ltyp)
689 -- Case where comparison involves two compile time known values
691 elsif Compile_Time_Known_Value (L)
692 and then Compile_Time_Known_Value (R)
694 -- For the floating-point case, we have to be a little careful, since
695 -- at compile time we are dealing with universal exact values, but at
696 -- runtime, these will be in non-exact target form. That's why the
697 -- returned results are LE and GE below instead of LT and GT.
699 if Is_Floating_Point_Type (Ltyp)
701 Is_Floating_Point_Type (Rtyp)
704 Lo : constant Ureal := Expr_Value_R (L);
705 Hi : constant Ureal := Expr_Value_R (R);
717 -- For the integer case we know exactly (note that this includes the
718 -- fixed-point case, where we know the run time integer values now)
722 Lo : constant Uint := Expr_Value (L);
723 Hi : constant Uint := Expr_Value (R);
736 -- Cases where at least one operand is not known at compile time
739 -- Remaining checks apply only for non-generic discrete types
741 if not Is_Discrete_Type (Ltyp)
742 or else not Is_Discrete_Type (Rtyp)
743 or else Is_Generic_Type (Ltyp)
744 or else Is_Generic_Type (Rtyp)
749 -- Replace types by base types for the case of entities which are
750 -- not known to have valid representations. This takes care of
751 -- properly dealing with invalid representations.
753 if not Assume_Valid and then not Assume_No_Invalid_Values then
754 if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
755 Ltyp := Base_Type (Ltyp);
758 if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
759 Rtyp := Base_Type (Rtyp);
763 -- Try range analysis on variables and see if ranges are disjoint
771 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
772 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
796 -- Here is where we check for comparisons against maximum bounds of
797 -- types, where we know that no value can be outside the bounds of
798 -- the subtype. Note that this routine is allowed to assume that all
799 -- expressions are within their subtype bounds. Callers wishing to
800 -- deal with possibly invalid values must in any case take special
801 -- steps (e.g. conversions to larger types) to avoid this kind of
802 -- optimization, which is always considered to be valid. We do not
803 -- attempt this optimization with generic types, since the type
804 -- bounds may not be meaningful in this case.
806 -- We are in danger of an infinite recursion here. It does not seem
807 -- useful to go more than one level deep, so the parameter Rec is
808 -- used to protect ourselves against this infinite recursion.
812 -- See if we can get a decisive check against one operand and
813 -- a bound of the other operand (four possible tests here).
815 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
816 Assume_Valid, Rec => True) is
817 when LT => return LT;
818 when LE => return LE;
819 when EQ => return LE;
823 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
824 Assume_Valid, Rec => True) is
825 when GT => return GT;
826 when GE => return GE;
827 when EQ => return GE;
831 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
832 Assume_Valid, Rec => True) is
833 when GT => return GT;
834 when GE => return GE;
835 when EQ => return GE;
839 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
840 Assume_Valid, Rec => True) is
841 when LT => return LT;
842 when LE => return LE;
843 when EQ => return LE;
848 -- Next attempt is to decompose the expressions to extract
849 -- a constant offset resulting from the use of any of the forms:
856 -- Then we see if the two expressions are the same value, and if so
857 -- the result is obtained by comparing the offsets.
866 Compare_Decompose (L, Lnode, Loffs);
867 Compare_Decompose (R, Rnode, Roffs);
869 if Is_Same_Value (Lnode, Rnode) then
870 if Loffs = Roffs then
873 elsif Loffs < Roffs then
882 -- Next attempt is to see if we have an entity compared with a
883 -- compile time known value, where there is a current value
884 -- conditional for the entity which can tell us the result.
888 -- Entity variable (left operand)
891 -- Value (right operand)
894 -- If False, we have reversed the operands
897 -- Comparison operator kind from Get_Current_Value_Condition call
900 -- Value from Get_Current_Value_Condition call
905 Result : Compare_Result;
906 -- Known result before inversion
909 if Is_Entity_Name (L)
910 and then Compile_Time_Known_Value (R)
913 Val := Expr_Value (R);
916 elsif Is_Entity_Name (R)
917 and then Compile_Time_Known_Value (L)
920 Val := Expr_Value (L);
923 -- That was the last chance at finding a compile time result
929 Get_Current_Value_Condition (Var, Op, Opn);
931 -- That was the last chance, so if we got nothing return
937 Opv := Expr_Value (Opn);
939 -- We got a comparison, so we might have something interesting
941 -- Convert LE to LT and GE to GT, just so we have fewer cases
946 elsif Op = N_Op_Ge then
951 -- Deal with equality case
962 -- Deal with inequality case
964 elsif Op = N_Op_Ne then
971 -- Deal with greater than case
973 elsif Op = N_Op_Gt then
976 elsif Opv = Val - 1 then
982 -- Deal with less than case
984 else pragma Assert (Op = N_Op_Lt);
987 elsif Opv = Val + 1 then
994 -- Deal with inverting result
998 when GT => return LT;
999 when GE => return LE;
1000 when LT => return GT;
1001 when LE => return GE;
1002 when others => return Result;
1009 end Compile_Time_Compare;
1011 -------------------------------
1012 -- Compile_Time_Known_Bounds --
1013 -------------------------------
1015 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1020 if not Is_Array_Type (T) then
1024 Indx := First_Index (T);
1025 while Present (Indx) loop
1026 Typ := Underlying_Type (Etype (Indx));
1027 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1029 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1037 end Compile_Time_Known_Bounds;
1039 ------------------------------
1040 -- Compile_Time_Known_Value --
1041 ------------------------------
1043 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1044 K : constant Node_Kind := Nkind (Op);
1045 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1048 -- Never known at compile time if bad type or raises constraint error
1049 -- or empty (latter case occurs only as a result of a previous error)
1053 or else Etype (Op) = Any_Type
1054 or else Raises_Constraint_Error (Op)
1059 -- If this is not a static expression or a null literal, and we are in
1060 -- configurable run-time mode, then we consider it not known at compile
1061 -- time. This avoids anomalies where whether something is allowed with a
1062 -- given configurable run-time library depends on how good the compiler
1063 -- is at optimizing and knowing that things are constant when they are
1066 if Configurable_Run_Time_Mode
1067 and then K /= N_Null
1068 and then not Is_Static_Expression (Op)
1073 -- If we have an entity name, then see if it is the name of a constant
1074 -- and if so, test the corresponding constant value, or the name of
1075 -- an enumeration literal, which is always a constant.
1077 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1079 E : constant Entity_Id := Entity (Op);
1083 -- Never known at compile time if it is a packed array value.
1084 -- We might want to try to evaluate these at compile time one
1085 -- day, but we do not make that attempt now.
1087 if Is_Packed_Array_Type (Etype (Op)) then
1091 if Ekind (E) = E_Enumeration_Literal then
1094 elsif Ekind (E) = E_Constant then
1095 V := Constant_Value (E);
1096 return Present (V) and then Compile_Time_Known_Value (V);
1100 -- We have a value, see if it is compile time known
1103 -- Integer literals are worth storing in the cache
1105 if K = N_Integer_Literal then
1107 CV_Ent.V := Intval (Op);
1110 -- Other literals and NULL are known at compile time
1113 K = N_Character_Literal
1117 K = N_String_Literal
1123 -- Any reference to Null_Parameter is known at compile time. No
1124 -- other attribute references (that have not already been folded)
1125 -- are known at compile time.
1127 elsif K = N_Attribute_Reference then
1128 return Attribute_Name (Op) = Name_Null_Parameter;
1132 -- If we fall through, not known at compile time
1136 -- If we get an exception while trying to do this test, then some error
1137 -- has occurred, and we simply say that the value is not known after all
1142 end Compile_Time_Known_Value;
1144 --------------------------------------
1145 -- Compile_Time_Known_Value_Or_Aggr --
1146 --------------------------------------
1148 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1150 -- If we have an entity name, then see if it is the name of a constant
1151 -- and if so, test the corresponding constant value, or the name of
1152 -- an enumeration literal, which is always a constant.
1154 if Is_Entity_Name (Op) then
1156 E : constant Entity_Id := Entity (Op);
1160 if Ekind (E) = E_Enumeration_Literal then
1163 elsif Ekind (E) /= E_Constant then
1167 V := Constant_Value (E);
1169 and then Compile_Time_Known_Value_Or_Aggr (V);
1173 -- We have a value, see if it is compile time known
1176 if Compile_Time_Known_Value (Op) then
1179 elsif Nkind (Op) = N_Aggregate then
1181 if Present (Expressions (Op)) then
1186 Expr := First (Expressions (Op));
1187 while Present (Expr) loop
1188 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1197 if Present (Component_Associations (Op)) then
1202 Cass := First (Component_Associations (Op));
1203 while Present (Cass) loop
1205 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1217 -- All other types of values are not known at compile time
1224 end Compile_Time_Known_Value_Or_Aggr;
1230 -- This is only called for actuals of functions that are not predefined
1231 -- operators (which have already been rewritten as operators at this
1232 -- stage), so the call can never be folded, and all that needs doing for
1233 -- the actual is to do the check for a non-static context.
1235 procedure Eval_Actual (N : Node_Id) is
1237 Check_Non_Static_Context (N);
1240 --------------------
1241 -- Eval_Allocator --
1242 --------------------
1244 -- Allocators are never static, so all we have to do is to do the
1245 -- check for a non-static context if an expression is present.
1247 procedure Eval_Allocator (N : Node_Id) is
1248 Expr : constant Node_Id := Expression (N);
1251 if Nkind (Expr) = N_Qualified_Expression then
1252 Check_Non_Static_Context (Expression (Expr));
1256 ------------------------
1257 -- Eval_Arithmetic_Op --
1258 ------------------------
1260 -- Arithmetic operations are static functions, so the result is static
1261 -- if both operands are static (RM 4.9(7), 4.9(20)).
1263 procedure Eval_Arithmetic_Op (N : Node_Id) is
1264 Left : constant Node_Id := Left_Opnd (N);
1265 Right : constant Node_Id := Right_Opnd (N);
1266 Ltype : constant Entity_Id := Etype (Left);
1267 Rtype : constant Entity_Id := Etype (Right);
1272 -- If not foldable we are done
1274 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1280 -- Fold for cases where both operands are of integer type
1282 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1284 Left_Int : constant Uint := Expr_Value (Left);
1285 Right_Int : constant Uint := Expr_Value (Right);
1292 Result := Left_Int + Right_Int;
1294 when N_Op_Subtract =>
1295 Result := Left_Int - Right_Int;
1297 when N_Op_Multiply =>
1300 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1302 Result := Left_Int * Right_Int;
1309 -- The exception Constraint_Error is raised by integer
1310 -- division, rem and mod if the right operand is zero.
1312 if Right_Int = 0 then
1313 Apply_Compile_Time_Constraint_Error
1314 (N, "division by zero",
1320 Result := Left_Int / Right_Int;
1325 -- The exception Constraint_Error is raised by integer
1326 -- division, rem and mod if the right operand is zero.
1328 if Right_Int = 0 then
1329 Apply_Compile_Time_Constraint_Error
1330 (N, "mod with zero divisor",
1335 Result := Left_Int mod Right_Int;
1340 -- The exception Constraint_Error is raised by integer
1341 -- division, rem and mod if the right operand is zero.
1343 if Right_Int = 0 then
1344 Apply_Compile_Time_Constraint_Error
1345 (N, "rem with zero divisor",
1351 Result := Left_Int rem Right_Int;
1355 raise Program_Error;
1358 -- Adjust the result by the modulus if the type is a modular type
1360 if Is_Modular_Integer_Type (Ltype) then
1361 Result := Result mod Modulus (Ltype);
1363 -- For a signed integer type, check non-static overflow
1365 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1367 BT : constant Entity_Id := Base_Type (Ltype);
1368 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1369 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1371 if Result < Lo or else Result > Hi then
1372 Apply_Compile_Time_Constraint_Error
1373 (N, "value not in range of }?",
1374 CE_Overflow_Check_Failed,
1381 -- If we get here we can fold the result
1383 Fold_Uint (N, Result, Stat);
1386 -- Cases where at least one operand is a real. We handle the cases
1387 -- of both reals, or mixed/real integer cases (the latter happen
1388 -- only for divide and multiply, and the result is always real).
1390 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1397 if Is_Real_Type (Ltype) then
1398 Left_Real := Expr_Value_R (Left);
1400 Left_Real := UR_From_Uint (Expr_Value (Left));
1403 if Is_Real_Type (Rtype) then
1404 Right_Real := Expr_Value_R (Right);
1406 Right_Real := UR_From_Uint (Expr_Value (Right));
1409 if Nkind (N) = N_Op_Add then
1410 Result := Left_Real + Right_Real;
1412 elsif Nkind (N) = N_Op_Subtract then
1413 Result := Left_Real - Right_Real;
1415 elsif Nkind (N) = N_Op_Multiply then
1416 Result := Left_Real * Right_Real;
1418 else pragma Assert (Nkind (N) = N_Op_Divide);
1419 if UR_Is_Zero (Right_Real) then
1420 Apply_Compile_Time_Constraint_Error
1421 (N, "division by zero", CE_Divide_By_Zero);
1425 Result := Left_Real / Right_Real;
1428 Fold_Ureal (N, Result, Stat);
1431 end Eval_Arithmetic_Op;
1433 ----------------------------
1434 -- Eval_Character_Literal --
1435 ----------------------------
1437 -- Nothing to be done!
1439 procedure Eval_Character_Literal (N : Node_Id) is
1440 pragma Warnings (Off, N);
1443 end Eval_Character_Literal;
1449 -- Static function calls are either calls to predefined operators
1450 -- with static arguments, or calls to functions that rename a literal.
1451 -- Only the latter case is handled here, predefined operators are
1452 -- constant-folded elsewhere.
1454 -- If the function is itself inherited (see 7423-001) the literal of
1455 -- the parent type must be explicitly converted to the return type
1458 procedure Eval_Call (N : Node_Id) is
1459 Loc : constant Source_Ptr := Sloc (N);
1460 Typ : constant Entity_Id := Etype (N);
1464 if Nkind (N) = N_Function_Call
1465 and then No (Parameter_Associations (N))
1466 and then Is_Entity_Name (Name (N))
1467 and then Present (Alias (Entity (Name (N))))
1468 and then Is_Enumeration_Type (Base_Type (Typ))
1470 Lit := Alias (Entity (Name (N)));
1471 while Present (Alias (Lit)) loop
1475 if Ekind (Lit) = E_Enumeration_Literal then
1476 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
1478 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
1480 Rewrite (N, New_Occurrence_Of (Lit, Loc));
1488 ------------------------
1489 -- Eval_Concatenation --
1490 ------------------------
1492 -- Concatenation is a static function, so the result is static if both
1493 -- operands are static (RM 4.9(7), 4.9(21)).
1495 procedure Eval_Concatenation (N : Node_Id) is
1496 Left : constant Node_Id := Left_Opnd (N);
1497 Right : constant Node_Id := Right_Opnd (N);
1498 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
1503 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
1504 -- non-static context.
1506 if Ada_Version = Ada_83
1507 and then Comes_From_Source (N)
1509 Check_Non_Static_Context (Left);
1510 Check_Non_Static_Context (Right);
1514 -- If not foldable we are done. In principle concatenation that yields
1515 -- any string type is static (i.e. an array type of character types).
1516 -- However, character types can include enumeration literals, and
1517 -- concatenation in that case cannot be described by a literal, so we
1518 -- only consider the operation static if the result is an array of
1519 -- (a descendant of) a predefined character type.
1521 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1523 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
1524 Set_Is_Static_Expression (N, False);
1528 -- Compile time string concatenation
1530 -- ??? Note that operands that are aggregates can be marked as static,
1531 -- so we should attempt at a later stage to fold concatenations with
1535 Left_Str : constant Node_Id := Get_String_Val (Left);
1537 Right_Str : constant Node_Id := Get_String_Val (Right);
1538 Folded_Val : String_Id;
1541 -- Establish new string literal, and store left operand. We make
1542 -- sure to use the special Start_String that takes an operand if
1543 -- the left operand is a string literal. Since this is optimized
1544 -- in the case where that is the most recently created string
1545 -- literal, we ensure efficient time/space behavior for the
1546 -- case of a concatenation of a series of string literals.
1548 if Nkind (Left_Str) = N_String_Literal then
1549 Left_Len := String_Length (Strval (Left_Str));
1551 -- If the left operand is the empty string, and the right operand
1552 -- is a string literal (the case of "" & "..."), the result is the
1553 -- value of the right operand. This optimization is important when
1554 -- Is_Folded_In_Parser, to avoid copying an enormous right
1557 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
1558 Folded_Val := Strval (Right_Str);
1560 Start_String (Strval (Left_Str));
1565 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
1569 -- Now append the characters of the right operand, unless we
1570 -- optimized the "" & "..." case above.
1572 if Nkind (Right_Str) = N_String_Literal then
1573 if Left_Len /= 0 then
1574 Store_String_Chars (Strval (Right_Str));
1575 Folded_Val := End_String;
1578 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
1579 Folded_Val := End_String;
1582 Set_Is_Static_Expression (N, Stat);
1586 -- If left operand is the empty string, the result is the
1587 -- right operand, including its bounds if anomalous.
1590 and then Is_Array_Type (Etype (Right))
1591 and then Etype (Right) /= Any_String
1593 Set_Etype (N, Etype (Right));
1596 Fold_Str (N, Folded_Val, Static => True);
1599 end Eval_Concatenation;
1601 ---------------------------------
1602 -- Eval_Conditional_Expression --
1603 ---------------------------------
1605 -- This GNAT internal construct can never be statically folded, so the
1606 -- only required processing is to do the check for non-static context
1607 -- for the two expression operands.
1609 procedure Eval_Conditional_Expression (N : Node_Id) is
1610 Condition : constant Node_Id := First (Expressions (N));
1611 Then_Expr : constant Node_Id := Next (Condition);
1612 Else_Expr : constant Node_Id := Next (Then_Expr);
1615 Check_Non_Static_Context (Then_Expr);
1616 Check_Non_Static_Context (Else_Expr);
1617 end Eval_Conditional_Expression;
1619 ----------------------
1620 -- Eval_Entity_Name --
1621 ----------------------
1623 -- This procedure is used for identifiers and expanded names other than
1624 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1625 -- static if they denote a static constant (RM 4.9(6)) or if the name
1626 -- denotes an enumeration literal (RM 4.9(22)).
1628 procedure Eval_Entity_Name (N : Node_Id) is
1629 Def_Id : constant Entity_Id := Entity (N);
1633 -- Enumeration literals are always considered to be constants
1634 -- and cannot raise constraint error (RM 4.9(22)).
1636 if Ekind (Def_Id) = E_Enumeration_Literal then
1637 Set_Is_Static_Expression (N);
1640 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1641 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1642 -- it does not violate 10.2.1(8) here, since this is not a variable.
1644 elsif Ekind (Def_Id) = E_Constant then
1646 -- Deferred constants must always be treated as nonstatic
1647 -- outside the scope of their full view.
1649 if Present (Full_View (Def_Id))
1650 and then not In_Open_Scopes (Scope (Def_Id))
1654 Val := Constant_Value (Def_Id);
1657 if Present (Val) then
1658 Set_Is_Static_Expression
1659 (N, Is_Static_Expression (Val)
1660 and then Is_Static_Subtype (Etype (Def_Id)));
1661 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1663 if not Is_Static_Expression (N)
1664 and then not Is_Generic_Type (Etype (N))
1666 Validate_Static_Object_Name (N);
1673 -- Fall through if the name is not static
1675 Validate_Static_Object_Name (N);
1676 end Eval_Entity_Name;
1678 ----------------------------
1679 -- Eval_Indexed_Component --
1680 ----------------------------
1682 -- Indexed components are never static, so we need to perform the check
1683 -- for non-static context on the index values. Then, we check if the
1684 -- value can be obtained at compile time, even though it is non-static.
1686 procedure Eval_Indexed_Component (N : Node_Id) is
1690 -- Check for non-static context on index values
1692 Expr := First (Expressions (N));
1693 while Present (Expr) loop
1694 Check_Non_Static_Context (Expr);
1698 -- If the indexed component appears in an object renaming declaration
1699 -- then we do not want to try to evaluate it, since in this case we
1700 -- need the identity of the array element.
1702 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
1705 -- Similarly if the indexed component appears as the prefix of an
1706 -- attribute we don't want to evaluate it, because at least for
1707 -- some cases of attributes we need the identify (e.g. Access, Size)
1709 elsif Nkind (Parent (N)) = N_Attribute_Reference then
1713 -- Note: there are other cases, such as the left side of an assignment,
1714 -- or an OUT parameter for a call, where the replacement results in the
1715 -- illegal use of a constant, But these cases are illegal in the first
1716 -- place, so the replacement, though silly, is harmless.
1718 -- Now see if this is a constant array reference
1720 if List_Length (Expressions (N)) = 1
1721 and then Is_Entity_Name (Prefix (N))
1722 and then Ekind (Entity (Prefix (N))) = E_Constant
1723 and then Present (Constant_Value (Entity (Prefix (N))))
1726 Loc : constant Source_Ptr := Sloc (N);
1727 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
1728 Sub : constant Node_Id := First (Expressions (N));
1734 -- Linear one's origin subscript value for array reference
1737 -- Lower bound of the first array index
1740 -- Value from constant array
1743 Atyp := Etype (Arr);
1745 if Is_Access_Type (Atyp) then
1746 Atyp := Designated_Type (Atyp);
1749 -- If we have an array type (we should have but perhaps there
1750 -- are error cases where this is not the case), then see if we
1751 -- can do a constant evaluation of the array reference.
1753 if Is_Array_Type (Atyp) then
1754 if Ekind (Atyp) = E_String_Literal_Subtype then
1755 Lbd := String_Literal_Low_Bound (Atyp);
1757 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
1760 if Compile_Time_Known_Value (Sub)
1761 and then Nkind (Arr) = N_Aggregate
1762 and then Compile_Time_Known_Value (Lbd)
1763 and then Is_Discrete_Type (Component_Type (Atyp))
1765 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
1767 if List_Length (Expressions (Arr)) >= Lin then
1768 Elm := Pick (Expressions (Arr), Lin);
1770 -- If the resulting expression is compile time known,
1771 -- then we can rewrite the indexed component with this
1772 -- value, being sure to mark the result as non-static.
1773 -- We also reset the Sloc, in case this generates an
1774 -- error later on (e.g. 136'Access).
1776 if Compile_Time_Known_Value (Elm) then
1777 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
1778 Set_Is_Static_Expression (N, False);
1786 end Eval_Indexed_Component;
1788 --------------------------
1789 -- Eval_Integer_Literal --
1790 --------------------------
1792 -- Numeric literals are static (RM 4.9(1)), and have already been marked
1793 -- as static by the analyzer. The reason we did it that early is to allow
1794 -- the possibility of turning off the Is_Static_Expression flag after
1795 -- analysis, but before resolution, when integer literals are generated
1796 -- in the expander that do not correspond to static expressions.
1798 procedure Eval_Integer_Literal (N : Node_Id) is
1799 T : constant Entity_Id := Etype (N);
1801 function In_Any_Integer_Context return Boolean;
1802 -- If the literal is resolved with a specific type in a context
1803 -- where the expected type is Any_Integer, there are no range checks
1804 -- on the literal. By the time the literal is evaluated, it carries
1805 -- the type imposed by the enclosing expression, and we must recover
1806 -- the context to determine that Any_Integer is meant.
1808 ----------------------------
1809 -- To_Any_Integer_Context --
1810 ----------------------------
1812 function In_Any_Integer_Context return Boolean is
1813 Par : constant Node_Id := Parent (N);
1814 K : constant Node_Kind := Nkind (Par);
1817 -- Any_Integer also appears in digits specifications for real types,
1818 -- but those have bounds smaller that those of any integer base
1819 -- type, so we can safely ignore these cases.
1821 return K = N_Number_Declaration
1822 or else K = N_Attribute_Reference
1823 or else K = N_Attribute_Definition_Clause
1824 or else K = N_Modular_Type_Definition
1825 or else K = N_Signed_Integer_Type_Definition;
1826 end In_Any_Integer_Context;
1828 -- Start of processing for Eval_Integer_Literal
1832 -- If the literal appears in a non-expression context, then it is
1833 -- certainly appearing in a non-static context, so check it. This
1834 -- is actually a redundant check, since Check_Non_Static_Context
1835 -- would check it, but it seems worth while avoiding the call.
1837 if Nkind (Parent (N)) not in N_Subexpr
1838 and then not In_Any_Integer_Context
1840 Check_Non_Static_Context (N);
1843 -- Modular integer literals must be in their base range
1845 if Is_Modular_Integer_Type (T)
1846 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
1850 end Eval_Integer_Literal;
1852 ---------------------
1853 -- Eval_Logical_Op --
1854 ---------------------
1856 -- Logical operations are static functions, so the result is potentially
1857 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1859 procedure Eval_Logical_Op (N : Node_Id) is
1860 Left : constant Node_Id := Left_Opnd (N);
1861 Right : constant Node_Id := Right_Opnd (N);
1866 -- If not foldable we are done
1868 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1874 -- Compile time evaluation of logical operation
1877 Left_Int : constant Uint := Expr_Value (Left);
1878 Right_Int : constant Uint := Expr_Value (Right);
1881 if Is_Modular_Integer_Type (Etype (N)) then
1883 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1884 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1887 To_Bits (Left_Int, Left_Bits);
1888 To_Bits (Right_Int, Right_Bits);
1890 -- Note: should really be able to use array ops instead of
1891 -- these loops, but they weren't working at the time ???
1893 if Nkind (N) = N_Op_And then
1894 for J in Left_Bits'Range loop
1895 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
1898 elsif Nkind (N) = N_Op_Or then
1899 for J in Left_Bits'Range loop
1900 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
1904 pragma Assert (Nkind (N) = N_Op_Xor);
1906 for J in Left_Bits'Range loop
1907 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
1911 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
1915 pragma Assert (Is_Boolean_Type (Etype (N)));
1917 if Nkind (N) = N_Op_And then
1919 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
1921 elsif Nkind (N) = N_Op_Or then
1923 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
1926 pragma Assert (Nkind (N) = N_Op_Xor);
1928 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
1932 end Eval_Logical_Op;
1934 ------------------------
1935 -- Eval_Membership_Op --
1936 ------------------------
1938 -- A membership test is potentially static if the expression is static,
1939 -- and the range is a potentially static range, or is a subtype mark
1940 -- denoting a static subtype (RM 4.9(12)).
1942 procedure Eval_Membership_Op (N : Node_Id) is
1943 Left : constant Node_Id := Left_Opnd (N);
1944 Right : constant Node_Id := Right_Opnd (N);
1953 -- Ignore if error in either operand, except to make sure that
1954 -- Any_Type is properly propagated to avoid junk cascaded errors.
1956 if Etype (Left) = Any_Type
1957 or else Etype (Right) = Any_Type
1959 Set_Etype (N, Any_Type);
1963 -- Case of right operand is a subtype name
1965 if Is_Entity_Name (Right) then
1966 Def_Id := Entity (Right);
1968 if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
1969 and then Is_OK_Static_Subtype (Def_Id)
1971 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
1973 if not Fold or else not Stat then
1977 Check_Non_Static_Context (Left);
1981 -- For string membership tests we will check the length
1984 if not Is_String_Type (Def_Id) then
1985 Lo := Type_Low_Bound (Def_Id);
1986 Hi := Type_High_Bound (Def_Id);
1993 -- Case of right operand is a range
1996 if Is_Static_Range (Right) then
1997 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
1999 if not Fold or else not Stat then
2002 -- If one bound of range raises CE, then don't try to fold
2004 elsif not Is_OK_Static_Range (Right) then
2005 Check_Non_Static_Context (Left);
2010 Check_Non_Static_Context (Left);
2014 -- Here we know range is an OK static range
2016 Lo := Low_Bound (Right);
2017 Hi := High_Bound (Right);
2020 -- For strings we check that the length of the string expression is
2021 -- compatible with the string subtype if the subtype is constrained,
2022 -- or if unconstrained then the test is always true.
2024 if Is_String_Type (Etype (Right)) then
2025 if not Is_Constrained (Etype (Right)) then
2030 Typlen : constant Uint := String_Type_Len (Etype (Right));
2031 Strlen : constant Uint :=
2032 UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
2034 Result := (Typlen = Strlen);
2038 -- Fold the membership test. We know we have a static range and Lo
2039 -- and Hi are set to the expressions for the end points of this range.
2041 elsif Is_Real_Type (Etype (Right)) then
2043 Leftval : constant Ureal := Expr_Value_R (Left);
2046 Result := Expr_Value_R (Lo) <= Leftval
2047 and then Leftval <= Expr_Value_R (Hi);
2052 Leftval : constant Uint := Expr_Value (Left);
2055 Result := Expr_Value (Lo) <= Leftval
2056 and then Leftval <= Expr_Value (Hi);
2060 if Nkind (N) = N_Not_In then
2061 Result := not Result;
2064 Fold_Uint (N, Test (Result), True);
2065 Warn_On_Known_Condition (N);
2066 end Eval_Membership_Op;
2068 ------------------------
2069 -- Eval_Named_Integer --
2070 ------------------------
2072 procedure Eval_Named_Integer (N : Node_Id) is
2075 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2076 end Eval_Named_Integer;
2078 ---------------------
2079 -- Eval_Named_Real --
2080 ---------------------
2082 procedure Eval_Named_Real (N : Node_Id) is
2085 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2086 end Eval_Named_Real;
2092 -- Exponentiation is a static functions, so the result is potentially
2093 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2095 procedure Eval_Op_Expon (N : Node_Id) is
2096 Left : constant Node_Id := Left_Opnd (N);
2097 Right : constant Node_Id := Right_Opnd (N);
2102 -- If not foldable we are done
2104 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2110 -- Fold exponentiation operation
2113 Right_Int : constant Uint := Expr_Value (Right);
2118 if Is_Integer_Type (Etype (Left)) then
2120 Left_Int : constant Uint := Expr_Value (Left);
2124 -- Exponentiation of an integer raises the exception
2125 -- Constraint_Error for a negative exponent (RM 4.5.6)
2127 if Right_Int < 0 then
2128 Apply_Compile_Time_Constraint_Error
2129 (N, "integer exponent negative",
2130 CE_Range_Check_Failed,
2135 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2136 Result := Left_Int ** Right_Int;
2141 if Is_Modular_Integer_Type (Etype (N)) then
2142 Result := Result mod Modulus (Etype (N));
2145 Fold_Uint (N, Result, Stat);
2153 Left_Real : constant Ureal := Expr_Value_R (Left);
2156 -- Cannot have a zero base with a negative exponent
2158 if UR_Is_Zero (Left_Real) then
2160 if Right_Int < 0 then
2161 Apply_Compile_Time_Constraint_Error
2162 (N, "zero ** negative integer",
2163 CE_Range_Check_Failed,
2167 Fold_Ureal (N, Ureal_0, Stat);
2171 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2182 -- The not operation is a static functions, so the result is potentially
2183 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2185 procedure Eval_Op_Not (N : Node_Id) is
2186 Right : constant Node_Id := Right_Opnd (N);
2191 -- If not foldable we are done
2193 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2199 -- Fold not operation
2202 Rint : constant Uint := Expr_Value (Right);
2203 Typ : constant Entity_Id := Etype (N);
2206 -- Negation is equivalent to subtracting from the modulus minus
2207 -- one. For a binary modulus this is equivalent to the ones-
2208 -- component of the original value. For non-binary modulus this
2209 -- is an arbitrary but consistent definition.
2211 if Is_Modular_Integer_Type (Typ) then
2212 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2215 pragma Assert (Is_Boolean_Type (Typ));
2216 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2219 Set_Is_Static_Expression (N, Stat);
2223 -------------------------------
2224 -- Eval_Qualified_Expression --
2225 -------------------------------
2227 -- A qualified expression is potentially static if its subtype mark denotes
2228 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2230 procedure Eval_Qualified_Expression (N : Node_Id) is
2231 Operand : constant Node_Id := Expression (N);
2232 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2239 -- Can only fold if target is string or scalar and subtype is static
2240 -- Also, do not fold if our parent is an allocator (this is because
2241 -- the qualified expression is really part of the syntactic structure
2242 -- of an allocator, and we do not want to end up with something that
2243 -- corresponds to "new 1" where the 1 is the result of folding a
2244 -- qualified expression).
2246 if not Is_Static_Subtype (Target_Type)
2247 or else Nkind (Parent (N)) = N_Allocator
2249 Check_Non_Static_Context (Operand);
2251 -- If operand is known to raise constraint_error, set the
2252 -- flag on the expression so it does not get optimized away.
2254 if Nkind (Operand) = N_Raise_Constraint_Error then
2255 Set_Raises_Constraint_Error (N);
2261 -- If not foldable we are done
2263 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2268 -- Don't try fold if target type has constraint error bounds
2270 elsif not Is_OK_Static_Subtype (Target_Type) then
2271 Set_Raises_Constraint_Error (N);
2275 -- Here we will fold, save Print_In_Hex indication
2277 Hex := Nkind (Operand) = N_Integer_Literal
2278 and then Print_In_Hex (Operand);
2280 -- Fold the result of qualification
2282 if Is_Discrete_Type (Target_Type) then
2283 Fold_Uint (N, Expr_Value (Operand), Stat);
2285 -- Preserve Print_In_Hex indication
2287 if Hex and then Nkind (N) = N_Integer_Literal then
2288 Set_Print_In_Hex (N);
2291 elsif Is_Real_Type (Target_Type) then
2292 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
2295 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
2298 Set_Is_Static_Expression (N, False);
2300 Check_String_Literal_Length (N, Target_Type);
2306 -- The expression may be foldable but not static
2308 Set_Is_Static_Expression (N, Stat);
2310 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
2313 end Eval_Qualified_Expression;
2315 -----------------------
2316 -- Eval_Real_Literal --
2317 -----------------------
2319 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2320 -- as static by the analyzer. The reason we did it that early is to allow
2321 -- the possibility of turning off the Is_Static_Expression flag after
2322 -- analysis, but before resolution, when integer literals are generated
2323 -- in the expander that do not correspond to static expressions.
2325 procedure Eval_Real_Literal (N : Node_Id) is
2326 PK : constant Node_Kind := Nkind (Parent (N));
2329 -- If the literal appears in a non-expression context
2330 -- and not as part of a number declaration, then it is
2331 -- appearing in a non-static context, so check it.
2333 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
2334 Check_Non_Static_Context (N);
2336 end Eval_Real_Literal;
2338 ------------------------
2339 -- Eval_Relational_Op --
2340 ------------------------
2342 -- Relational operations are static functions, so the result is static
2343 -- if both operands are static (RM 4.9(7), 4.9(20)).
2345 procedure Eval_Relational_Op (N : Node_Id) is
2346 Left : constant Node_Id := Left_Opnd (N);
2347 Right : constant Node_Id := Right_Opnd (N);
2348 Typ : constant Entity_Id := Etype (Left);
2354 -- One special case to deal with first. If we can tell that the result
2355 -- will be false because the lengths of one or more index subtypes are
2356 -- compile time known and different, then we can replace the entire
2357 -- result by False. We only do this for one dimensional arrays, because
2358 -- the case of multi-dimensional arrays is rare and too much trouble! If
2359 -- one of the operands is an illegal aggregate, its type might still be
2360 -- an arbitrary composite type, so nothing to do.
2362 if Is_Array_Type (Typ)
2363 and then Typ /= Any_Composite
2364 and then Number_Dimensions (Typ) = 1
2365 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
2367 if Raises_Constraint_Error (Left)
2368 or else Raises_Constraint_Error (Right)
2373 -- OK, we have the case where we may be able to do this fold
2375 Length_Mismatch : declare
2376 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
2377 -- If Op is an expression for a constrained array with a known
2378 -- at compile time length, then Len is set to this (non-negative
2379 -- length). Otherwise Len is set to minus 1.
2381 -----------------------
2382 -- Get_Static_Length --
2383 -----------------------
2385 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2389 -- First easy case string literal
2391 if Nkind (Op) = N_String_Literal then
2392 Len := UI_From_Int (String_Length (Strval (Op)));
2396 -- Second easy case, not constrained subtype, so no length
2398 if not Is_Constrained (Etype (Op)) then
2399 Len := Uint_Minus_1;
2405 T := Etype (First_Index (Etype (Op)));
2407 -- The simple case, both bounds are known at compile time
2409 if Is_Discrete_Type (T)
2411 Compile_Time_Known_Value (Type_Low_Bound (T))
2413 Compile_Time_Known_Value (Type_High_Bound (T))
2415 Len := UI_Max (Uint_0,
2416 Expr_Value (Type_High_Bound (T)) -
2417 Expr_Value (Type_Low_Bound (T)) + 1);
2421 -- A more complex case, where the bounds are of the form
2422 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2423 -- either A'First or A'Last (with A an entity name), or X is an
2424 -- entity name, and the two X's are the same and K1 and K2 are
2425 -- known at compile time, in this case, the length can also be
2426 -- computed at compile time, even though the bounds are not
2427 -- known. A common case of this is e.g. (X'First..X'First+5).
2429 Extract_Length : declare
2430 procedure Decompose_Expr
2432 Ent : out Entity_Id;
2433 Kind : out Character;
2435 -- Given an expression, see if is of the form above,
2436 -- X [+/- K]. If so Ent is set to the entity in X,
2437 -- Kind is 'F','L','E' for 'First/'Last/simple entity,
2438 -- and Cons is the value of K. If the expression is
2439 -- not of the required form, Ent is set to Empty.
2441 --------------------
2442 -- Decompose_Expr --
2443 --------------------
2445 procedure Decompose_Expr
2447 Ent : out Entity_Id;
2448 Kind : out Character;
2454 if Nkind (Expr) = N_Op_Add
2455 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2457 Exp := Left_Opnd (Expr);
2458 Cons := Expr_Value (Right_Opnd (Expr));
2460 elsif Nkind (Expr) = N_Op_Subtract
2461 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2463 Exp := Left_Opnd (Expr);
2464 Cons := -Expr_Value (Right_Opnd (Expr));
2471 -- At this stage Exp is set to the potential X
2473 if Nkind (Exp) = N_Attribute_Reference then
2474 if Attribute_Name (Exp) = Name_First then
2476 elsif Attribute_Name (Exp) = Name_Last then
2483 Exp := Prefix (Exp);
2489 if Is_Entity_Name (Exp)
2490 and then Present (Entity (Exp))
2492 Ent := Entity (Exp);
2500 Ent1, Ent2 : Entity_Id;
2501 Kind1, Kind2 : Character;
2502 Cons1, Cons2 : Uint;
2504 -- Start of processing for Extract_Length
2507 Decompose_Expr (Type_Low_Bound (T), Ent1, Kind1, Cons1);
2508 Decompose_Expr (Type_High_Bound (T), Ent2, Kind2, Cons2);
2511 and then Kind1 = Kind2
2512 and then Ent1 = Ent2
2514 Len := Cons2 - Cons1 + 1;
2516 Len := Uint_Minus_1;
2519 end Get_Static_Length;
2526 -- Start of processing for Length_Mismatch
2529 Get_Static_Length (Left, Len_L);
2530 Get_Static_Length (Right, Len_R);
2532 if Len_L /= Uint_Minus_1
2533 and then Len_R /= Uint_Minus_1
2534 and then Len_L /= Len_R
2536 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2537 Warn_On_Known_Condition (N);
2540 end Length_Mismatch;
2543 -- Another special case: comparisons of access types, where one or both
2544 -- operands are known to be null, so the result can be determined.
2546 if Is_Access_Type (Typ) then
2547 if Known_Null (Left) then
2548 if Known_Null (Right) then
2549 Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False);
2550 Warn_On_Known_Condition (N);
2553 elsif Known_Non_Null (Right) then
2554 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2555 Warn_On_Known_Condition (N);
2559 elsif Known_Non_Null (Left) then
2560 if Known_Null (Right) then
2561 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2562 Warn_On_Known_Condition (N);
2568 -- Can only fold if type is scalar (don't fold string ops)
2570 if not Is_Scalar_Type (Typ) then
2571 Check_Non_Static_Context (Left);
2572 Check_Non_Static_Context (Right);
2576 -- If not foldable we are done
2578 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2584 -- Integer and Enumeration (discrete) type cases
2586 if Is_Discrete_Type (Typ) then
2588 Left_Int : constant Uint := Expr_Value (Left);
2589 Right_Int : constant Uint := Expr_Value (Right);
2593 when N_Op_Eq => Result := Left_Int = Right_Int;
2594 when N_Op_Ne => Result := Left_Int /= Right_Int;
2595 when N_Op_Lt => Result := Left_Int < Right_Int;
2596 when N_Op_Le => Result := Left_Int <= Right_Int;
2597 when N_Op_Gt => Result := Left_Int > Right_Int;
2598 when N_Op_Ge => Result := Left_Int >= Right_Int;
2601 raise Program_Error;
2604 Fold_Uint (N, Test (Result), Stat);
2610 pragma Assert (Is_Real_Type (Typ));
2613 Left_Real : constant Ureal := Expr_Value_R (Left);
2614 Right_Real : constant Ureal := Expr_Value_R (Right);
2618 when N_Op_Eq => Result := (Left_Real = Right_Real);
2619 when N_Op_Ne => Result := (Left_Real /= Right_Real);
2620 when N_Op_Lt => Result := (Left_Real < Right_Real);
2621 when N_Op_Le => Result := (Left_Real <= Right_Real);
2622 when N_Op_Gt => Result := (Left_Real > Right_Real);
2623 when N_Op_Ge => Result := (Left_Real >= Right_Real);
2626 raise Program_Error;
2629 Fold_Uint (N, Test (Result), Stat);
2633 Warn_On_Known_Condition (N);
2634 end Eval_Relational_Op;
2640 -- Shift operations are intrinsic operations that can never be static,
2641 -- so the only processing required is to perform the required check for
2642 -- a non static context for the two operands.
2644 -- Actually we could do some compile time evaluation here some time ???
2646 procedure Eval_Shift (N : Node_Id) is
2648 Check_Non_Static_Context (Left_Opnd (N));
2649 Check_Non_Static_Context (Right_Opnd (N));
2652 ------------------------
2653 -- Eval_Short_Circuit --
2654 ------------------------
2656 -- A short circuit operation is potentially static if both operands
2657 -- are potentially static (RM 4.9 (13))
2659 procedure Eval_Short_Circuit (N : Node_Id) is
2660 Kind : constant Node_Kind := Nkind (N);
2661 Left : constant Node_Id := Left_Opnd (N);
2662 Right : constant Node_Id := Right_Opnd (N);
2664 Rstat : constant Boolean :=
2665 Is_Static_Expression (Left)
2666 and then Is_Static_Expression (Right);
2669 -- Short circuit operations are never static in Ada 83
2671 if Ada_Version = Ada_83
2672 and then Comes_From_Source (N)
2674 Check_Non_Static_Context (Left);
2675 Check_Non_Static_Context (Right);
2679 -- Now look at the operands, we can't quite use the normal call to
2680 -- Test_Expression_Is_Foldable here because short circuit operations
2681 -- are a special case, they can still be foldable, even if the right
2682 -- operand raises constraint error.
2684 -- If either operand is Any_Type, just propagate to result and
2685 -- do not try to fold, this prevents cascaded errors.
2687 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2688 Set_Etype (N, Any_Type);
2691 -- If left operand raises constraint error, then replace node N with
2692 -- the raise constraint error node, and we are obviously not foldable.
2693 -- Is_Static_Expression is set from the two operands in the normal way,
2694 -- and we check the right operand if it is in a non-static context.
2696 elsif Raises_Constraint_Error (Left) then
2698 Check_Non_Static_Context (Right);
2701 Rewrite_In_Raise_CE (N, Left);
2702 Set_Is_Static_Expression (N, Rstat);
2705 -- If the result is not static, then we won't in any case fold
2707 elsif not Rstat then
2708 Check_Non_Static_Context (Left);
2709 Check_Non_Static_Context (Right);
2713 -- Here the result is static, note that, unlike the normal processing
2714 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
2715 -- the right operand raises constraint error, that's because it is not
2716 -- significant if the left operand is decisive.
2718 Set_Is_Static_Expression (N);
2720 -- It does not matter if the right operand raises constraint error if
2721 -- it will not be evaluated. So deal specially with the cases where
2722 -- the right operand is not evaluated. Note that we will fold these
2723 -- cases even if the right operand is non-static, which is fine, but
2724 -- of course in these cases the result is not potentially static.
2726 Left_Int := Expr_Value (Left);
2728 if (Kind = N_And_Then and then Is_False (Left_Int))
2729 or else (Kind = N_Or_Else and Is_True (Left_Int))
2731 Fold_Uint (N, Left_Int, Rstat);
2735 -- If first operand not decisive, then it does matter if the right
2736 -- operand raises constraint error, since it will be evaluated, so
2737 -- we simply replace the node with the right operand. Note that this
2738 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
2739 -- (both are set to True in Right).
2741 if Raises_Constraint_Error (Right) then
2742 Rewrite_In_Raise_CE (N, Right);
2743 Check_Non_Static_Context (Left);
2747 -- Otherwise the result depends on the right operand
2749 Fold_Uint (N, Expr_Value (Right), Rstat);
2751 end Eval_Short_Circuit;
2757 -- Slices can never be static, so the only processing required is to
2758 -- check for non-static context if an explicit range is given.
2760 procedure Eval_Slice (N : Node_Id) is
2761 Drange : constant Node_Id := Discrete_Range (N);
2763 if Nkind (Drange) = N_Range then
2764 Check_Non_Static_Context (Low_Bound (Drange));
2765 Check_Non_Static_Context (High_Bound (Drange));
2768 -- A slice of the form A (subtype), when the subtype is the index of
2769 -- the type of A, is redundant, the slice can be replaced with A, and
2770 -- this is worth a warning.
2772 if Is_Entity_Name (Prefix (N)) then
2774 E : constant Entity_Id := Entity (Prefix (N));
2775 T : constant Entity_Id := Etype (E);
2777 if Ekind (E) = E_Constant
2778 and then Is_Array_Type (T)
2779 and then Is_Entity_Name (Drange)
2781 if Is_Entity_Name (Original_Node (First_Index (T)))
2782 and then Entity (Original_Node (First_Index (T)))
2785 if Warn_On_Redundant_Constructs then
2786 Error_Msg_N ("redundant slice denotes whole array?", N);
2789 -- The following might be a useful optimization ????
2791 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
2798 -------------------------
2799 -- Eval_String_Literal --
2800 -------------------------
2802 procedure Eval_String_Literal (N : Node_Id) is
2803 Typ : constant Entity_Id := Etype (N);
2804 Bas : constant Entity_Id := Base_Type (Typ);
2810 -- Nothing to do if error type (handles cases like default expressions
2811 -- or generics where we have not yet fully resolved the type)
2813 if Bas = Any_Type or else Bas = Any_String then
2817 -- String literals are static if the subtype is static (RM 4.9(2)), so
2818 -- reset the static expression flag (it was set unconditionally in
2819 -- Analyze_String_Literal) if the subtype is non-static. We tell if
2820 -- the subtype is static by looking at the lower bound.
2822 if Ekind (Typ) = E_String_Literal_Subtype then
2823 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
2824 Set_Is_Static_Expression (N, False);
2828 -- Here if Etype of string literal is normal Etype (not yet possible,
2829 -- but may be possible in future!)
2831 elsif not Is_OK_Static_Expression
2832 (Type_Low_Bound (Etype (First_Index (Typ))))
2834 Set_Is_Static_Expression (N, False);
2838 -- If original node was a type conversion, then result if non-static
2840 if Nkind (Original_Node (N)) = N_Type_Conversion then
2841 Set_Is_Static_Expression (N, False);
2845 -- Test for illegal Ada 95 cases. A string literal is illegal in
2846 -- Ada 95 if its bounds are outside the index base type and this
2847 -- index type is static. This can happen in only two ways. Either
2848 -- the string literal is too long, or it is null, and the lower
2849 -- bound is type'First. In either case it is the upper bound that
2850 -- is out of range of the index type.
2852 if Ada_Version >= Ada_95 then
2853 if Root_Type (Bas) = Standard_String
2855 Root_Type (Bas) = Standard_Wide_String
2857 Xtp := Standard_Positive;
2859 Xtp := Etype (First_Index (Bas));
2862 if Ekind (Typ) = E_String_Literal_Subtype then
2863 Lo := String_Literal_Low_Bound (Typ);
2865 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
2868 Len := String_Length (Strval (N));
2870 if UI_From_Int (Len) > String_Type_Len (Bas) then
2871 Apply_Compile_Time_Constraint_Error
2872 (N, "string literal too long for}", CE_Length_Check_Failed,
2874 Typ => First_Subtype (Bas));
2877 and then not Is_Generic_Type (Xtp)
2879 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
2881 Apply_Compile_Time_Constraint_Error
2882 (N, "null string literal not allowed for}",
2883 CE_Length_Check_Failed,
2885 Typ => First_Subtype (Bas));
2888 end Eval_String_Literal;
2890 --------------------------
2891 -- Eval_Type_Conversion --
2892 --------------------------
2894 -- A type conversion is potentially static if its subtype mark is for a
2895 -- static scalar subtype, and its operand expression is potentially static
2898 procedure Eval_Type_Conversion (N : Node_Id) is
2899 Operand : constant Node_Id := Expression (N);
2900 Source_Type : constant Entity_Id := Etype (Operand);
2901 Target_Type : constant Entity_Id := Etype (N);
2906 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
2907 -- Returns true if type T is an integer type, or if it is a
2908 -- fixed-point type to be treated as an integer (i.e. the flag
2909 -- Conversion_OK is set on the conversion node).
2911 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
2912 -- Returns true if type T is a floating-point type, or if it is a
2913 -- fixed-point type that is not to be treated as an integer (i.e. the
2914 -- flag Conversion_OK is not set on the conversion node).
2916 ------------------------------
2917 -- To_Be_Treated_As_Integer --
2918 ------------------------------
2920 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
2924 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
2925 end To_Be_Treated_As_Integer;
2927 ---------------------------
2928 -- To_Be_Treated_As_Real --
2929 ---------------------------
2931 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
2934 Is_Floating_Point_Type (T)
2935 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
2936 end To_Be_Treated_As_Real;
2938 -- Start of processing for Eval_Type_Conversion
2941 -- Cannot fold if target type is non-static or if semantic error
2943 if not Is_Static_Subtype (Target_Type) then
2944 Check_Non_Static_Context (Operand);
2947 elsif Error_Posted (N) then
2951 -- If not foldable we are done
2953 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2958 -- Don't try fold if target type has constraint error bounds
2960 elsif not Is_OK_Static_Subtype (Target_Type) then
2961 Set_Raises_Constraint_Error (N);
2965 -- Remaining processing depends on operand types. Note that in the
2966 -- following type test, fixed-point counts as real unless the flag
2967 -- Conversion_OK is set, in which case it counts as integer.
2969 -- Fold conversion, case of string type. The result is not static
2971 if Is_String_Type (Target_Type) then
2972 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
2976 -- Fold conversion, case of integer target type
2978 elsif To_Be_Treated_As_Integer (Target_Type) then
2983 -- Integer to integer conversion
2985 if To_Be_Treated_As_Integer (Source_Type) then
2986 Result := Expr_Value (Operand);
2988 -- Real to integer conversion
2991 Result := UR_To_Uint (Expr_Value_R (Operand));
2994 -- If fixed-point type (Conversion_OK must be set), then the
2995 -- result is logically an integer, but we must replace the
2996 -- conversion with the corresponding real literal, since the
2997 -- type from a semantic point of view is still fixed-point.
2999 if Is_Fixed_Point_Type (Target_Type) then
3001 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3003 -- Otherwise result is integer literal
3006 Fold_Uint (N, Result, Stat);
3010 -- Fold conversion, case of real target type
3012 elsif To_Be_Treated_As_Real (Target_Type) then
3017 if To_Be_Treated_As_Real (Source_Type) then
3018 Result := Expr_Value_R (Operand);
3020 Result := UR_From_Uint (Expr_Value (Operand));
3023 Fold_Ureal (N, Result, Stat);
3026 -- Enumeration types
3029 Fold_Uint (N, Expr_Value (Operand), Stat);
3032 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3036 end Eval_Type_Conversion;
3042 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3043 -- are potentially static if the operand is potentially static (RM 4.9(7))
3045 procedure Eval_Unary_Op (N : Node_Id) is
3046 Right : constant Node_Id := Right_Opnd (N);
3051 -- If not foldable we are done
3053 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3059 -- Fold for integer case
3061 if Is_Integer_Type (Etype (N)) then
3063 Rint : constant Uint := Expr_Value (Right);
3067 -- In the case of modular unary plus and abs there is no need
3068 -- to adjust the result of the operation since if the original
3069 -- operand was in bounds the result will be in the bounds of the
3070 -- modular type. However, in the case of modular unary minus the
3071 -- result may go out of the bounds of the modular type and needs
3074 if Nkind (N) = N_Op_Plus then
3077 elsif Nkind (N) = N_Op_Minus then
3078 if Is_Modular_Integer_Type (Etype (N)) then
3079 Result := (-Rint) mod Modulus (Etype (N));
3085 pragma Assert (Nkind (N) = N_Op_Abs);
3089 Fold_Uint (N, Result, Stat);
3092 -- Fold for real case
3094 elsif Is_Real_Type (Etype (N)) then
3096 Rreal : constant Ureal := Expr_Value_R (Right);
3100 if Nkind (N) = N_Op_Plus then
3103 elsif Nkind (N) = N_Op_Minus then
3104 Result := UR_Negate (Rreal);
3107 pragma Assert (Nkind (N) = N_Op_Abs);
3108 Result := abs Rreal;
3111 Fold_Ureal (N, Result, Stat);
3116 -------------------------------
3117 -- Eval_Unchecked_Conversion --
3118 -------------------------------
3120 -- Unchecked conversions can never be static, so the only required
3121 -- processing is to check for a non-static context for the operand.
3123 procedure Eval_Unchecked_Conversion (N : Node_Id) is
3125 Check_Non_Static_Context (Expression (N));
3126 end Eval_Unchecked_Conversion;
3128 --------------------
3129 -- Expr_Rep_Value --
3130 --------------------
3132 function Expr_Rep_Value (N : Node_Id) return Uint is
3133 Kind : constant Node_Kind := Nkind (N);
3137 if Is_Entity_Name (N) then
3140 -- An enumeration literal that was either in the source or
3141 -- created as a result of static evaluation.
3143 if Ekind (Ent) = E_Enumeration_Literal then
3144 return Enumeration_Rep (Ent);
3146 -- A user defined static constant
3149 pragma Assert (Ekind (Ent) = E_Constant);
3150 return Expr_Rep_Value (Constant_Value (Ent));
3153 -- An integer literal that was either in the source or created
3154 -- as a result of static evaluation.
3156 elsif Kind = N_Integer_Literal then
3159 -- A real literal for a fixed-point type. This must be the fixed-point
3160 -- case, either the literal is of a fixed-point type, or it is a bound
3161 -- of a fixed-point type, with type universal real. In either case we
3162 -- obtain the desired value from Corresponding_Integer_Value.
3164 elsif Kind = N_Real_Literal then
3165 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3166 return Corresponding_Integer_Value (N);
3168 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3170 elsif Kind = N_Attribute_Reference
3171 and then Attribute_Name (N) = Name_Null_Parameter
3175 -- Otherwise must be character literal
3178 pragma Assert (Kind = N_Character_Literal);
3181 -- Since Character literals of type Standard.Character don't
3182 -- have any defining character literals built for them, they
3183 -- do not have their Entity set, so just use their Char
3184 -- code. Otherwise for user-defined character literals use
3185 -- their Pos value as usual which is the same as the Rep value.
3188 return Char_Literal_Value (N);
3190 return Enumeration_Rep (Ent);
3199 function Expr_Value (N : Node_Id) return Uint is
3200 Kind : constant Node_Kind := Nkind (N);
3201 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3206 -- If already in cache, then we know it's compile time known and we can
3207 -- return the value that was previously stored in the cache since
3208 -- compile time known values cannot change.
3210 if CV_Ent.N = N then
3214 -- Otherwise proceed to test value
3216 if Is_Entity_Name (N) then
3219 -- An enumeration literal that was either in the source or
3220 -- created as a result of static evaluation.
3222 if Ekind (Ent) = E_Enumeration_Literal then
3223 Val := Enumeration_Pos (Ent);
3225 -- A user defined static constant
3228 pragma Assert (Ekind (Ent) = E_Constant);
3229 Val := Expr_Value (Constant_Value (Ent));
3232 -- An integer literal that was either in the source or created
3233 -- as a result of static evaluation.
3235 elsif Kind = N_Integer_Literal then
3238 -- A real literal for a fixed-point type. This must be the fixed-point
3239 -- case, either the literal is of a fixed-point type, or it is a bound
3240 -- of a fixed-point type, with type universal real. In either case we
3241 -- obtain the desired value from Corresponding_Integer_Value.
3243 elsif Kind = N_Real_Literal then
3245 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3246 Val := Corresponding_Integer_Value (N);
3248 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3250 elsif Kind = N_Attribute_Reference
3251 and then Attribute_Name (N) = Name_Null_Parameter
3255 -- Otherwise must be character literal
3258 pragma Assert (Kind = N_Character_Literal);
3261 -- Since Character literals of type Standard.Character don't
3262 -- have any defining character literals built for them, they
3263 -- do not have their Entity set, so just use their Char
3264 -- code. Otherwise for user-defined character literals use
3265 -- their Pos value as usual.
3268 Val := Char_Literal_Value (N);
3270 Val := Enumeration_Pos (Ent);
3274 -- Come here with Val set to value to be returned, set cache
3285 function Expr_Value_E (N : Node_Id) return Entity_Id is
3286 Ent : constant Entity_Id := Entity (N);
3289 if Ekind (Ent) = E_Enumeration_Literal then
3292 pragma Assert (Ekind (Ent) = E_Constant);
3293 return Expr_Value_E (Constant_Value (Ent));
3301 function Expr_Value_R (N : Node_Id) return Ureal is
3302 Kind : constant Node_Kind := Nkind (N);
3307 if Kind = N_Real_Literal then
3310 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3312 pragma Assert (Ekind (Ent) = E_Constant);
3313 return Expr_Value_R (Constant_Value (Ent));
3315 elsif Kind = N_Integer_Literal then
3316 return UR_From_Uint (Expr_Value (N));
3318 -- Strange case of VAX literals, which are at this stage transformed
3319 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3320 -- Exp_Vfpt for further details.
3322 elsif Vax_Float (Etype (N))
3323 and then Nkind (N) = N_Unchecked_Type_Conversion
3325 Expr := Expression (N);
3327 if Nkind (Expr) = N_Function_Call
3328 and then Present (Parameter_Associations (Expr))
3330 Expr := First (Parameter_Associations (Expr));
3332 if Nkind (Expr) = N_Real_Literal then
3333 return Realval (Expr);
3337 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3339 elsif Kind = N_Attribute_Reference
3340 and then Attribute_Name (N) = Name_Null_Parameter
3345 -- If we fall through, we have a node that cannot be interpreted
3346 -- as a compile time constant. That is definitely an error.
3348 raise Program_Error;
3355 function Expr_Value_S (N : Node_Id) return Node_Id is
3357 if Nkind (N) = N_String_Literal then
3360 pragma Assert (Ekind (Entity (N)) = E_Constant);
3361 return Expr_Value_S (Constant_Value (Entity (N)));
3365 --------------------------
3366 -- Flag_Non_Static_Expr --
3367 --------------------------
3369 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
3371 if Error_Posted (Expr) and then not All_Errors_Mode then
3374 Error_Msg_F (Msg, Expr);
3375 Why_Not_Static (Expr);
3377 end Flag_Non_Static_Expr;
3383 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
3384 Loc : constant Source_Ptr := Sloc (N);
3385 Typ : constant Entity_Id := Etype (N);
3388 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
3390 -- We now have the literal with the right value, both the actual type
3391 -- and the expected type of this literal are taken from the expression
3392 -- that was evaluated.
3395 Set_Is_Static_Expression (N, Static);
3404 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
3405 Loc : constant Source_Ptr := Sloc (N);
3406 Typ : Entity_Id := Etype (N);
3410 -- If we are folding a named number, retain the entity in the
3411 -- literal, for ASIS use.
3413 if Is_Entity_Name (N)
3414 and then Ekind (Entity (N)) = E_Named_Integer
3421 if Is_Private_Type (Typ) then
3422 Typ := Full_View (Typ);
3425 -- For a result of type integer, substitute an N_Integer_Literal node
3426 -- for the result of the compile time evaluation of the expression.
3427 -- For ASIS use, set a link to the original named number when not in
3428 -- a generic context.
3430 if Is_Integer_Type (Typ) then
3431 Rewrite (N, Make_Integer_Literal (Loc, Val));
3433 Set_Original_Entity (N, Ent);
3435 -- Otherwise we have an enumeration type, and we substitute either
3436 -- an N_Identifier or N_Character_Literal to represent the enumeration
3437 -- literal corresponding to the given value, which must always be in
3438 -- range, because appropriate tests have already been made for this.
3440 else pragma Assert (Is_Enumeration_Type (Typ));
3441 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
3444 -- We now have the literal with the right value, both the actual type
3445 -- and the expected type of this literal are taken from the expression
3446 -- that was evaluated.
3449 Set_Is_Static_Expression (N, Static);
3458 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
3459 Loc : constant Source_Ptr := Sloc (N);
3460 Typ : constant Entity_Id := Etype (N);
3464 -- If we are folding a named number, retain the entity in the
3465 -- literal, for ASIS use.
3467 if Is_Entity_Name (N)
3468 and then Ekind (Entity (N)) = E_Named_Real
3475 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
3477 -- Set link to original named number, for ASIS use
3479 Set_Original_Entity (N, Ent);
3481 -- Both the actual and expected type comes from the original expression
3484 Set_Is_Static_Expression (N, Static);
3493 function From_Bits (B : Bits; T : Entity_Id) return Uint is
3497 for J in 0 .. B'Last loop
3503 if Non_Binary_Modulus (T) then
3504 V := V mod Modulus (T);
3510 --------------------
3511 -- Get_String_Val --
3512 --------------------
3514 function Get_String_Val (N : Node_Id) return Node_Id is
3516 if Nkind (N) = N_String_Literal then
3519 elsif Nkind (N) = N_Character_Literal then
3523 pragma Assert (Is_Entity_Name (N));
3524 return Get_String_Val (Constant_Value (Entity (N)));
3532 procedure Initialize is
3534 CV_Cache := (others => (Node_High_Bound, Uint_0));
3537 --------------------
3538 -- In_Subrange_Of --
3539 --------------------
3541 function In_Subrange_Of
3544 Fixed_Int : Boolean := False) return Boolean
3553 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
3556 -- Never in range if both types are not scalar. Don't know if this can
3557 -- actually happen, but just in case.
3559 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
3563 L1 := Type_Low_Bound (T1);
3564 H1 := Type_High_Bound (T1);
3566 L2 := Type_Low_Bound (T2);
3567 H2 := Type_High_Bound (T2);
3569 -- Check bounds to see if comparison possible at compile time
3571 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
3573 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
3578 -- If bounds not comparable at compile time, then the bounds of T2
3579 -- must be compile time known or we cannot answer the query.
3581 if not Compile_Time_Known_Value (L2)
3582 or else not Compile_Time_Known_Value (H2)
3587 -- If the bounds of T1 are know at compile time then use these
3588 -- ones, otherwise use the bounds of the base type (which are of
3589 -- course always static).
3591 if not Compile_Time_Known_Value (L1) then
3592 L1 := Type_Low_Bound (Base_Type (T1));
3595 if not Compile_Time_Known_Value (H1) then
3596 H1 := Type_High_Bound (Base_Type (T1));
3599 -- Fixed point types should be considered as such only if
3600 -- flag Fixed_Int is set to False.
3602 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
3603 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
3604 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
3607 Expr_Value_R (L2) <= Expr_Value_R (L1)
3609 Expr_Value_R (H2) >= Expr_Value_R (H1);
3613 Expr_Value (L2) <= Expr_Value (L1)
3615 Expr_Value (H2) >= Expr_Value (H1);
3620 -- If any exception occurs, it means that we have some bug in the compiler
3621 -- possibly triggered by a previous error, or by some unforeseen peculiar
3622 -- occurrence. However, this is only an optimization attempt, so there is
3623 -- really no point in crashing the compiler. Instead we just decide, too
3624 -- bad, we can't figure out the answer in this case after all.
3629 -- Debug flag K disables this behavior (useful for debugging)
3631 if Debug_Flag_K then
3642 function Is_In_Range
3645 Assume_Valid : Boolean := False;
3646 Fixed_Int : Boolean := False;
3647 Int_Real : Boolean := False) return Boolean
3652 pragma Warnings (Off, Assume_Valid);
3653 -- For now Assume_Valid is unreferenced since the current implementation
3654 -- always returns False if N is not a compile time known value, but we
3655 -- keep the parameter to allow for future enhancements in which we try
3656 -- to get the information in the variable case as well.
3659 -- Universal types have no range limits, so always in range
3661 if Typ = Universal_Integer or else Typ = Universal_Real then
3664 -- Never in range if not scalar type. Don't know if this can
3665 -- actually happen, but our spec allows it, so we must check!
3667 elsif not Is_Scalar_Type (Typ) then
3670 -- Never in range unless we have a compile time known value
3672 elsif not Compile_Time_Known_Value (N) then
3675 -- General processing with a known compile time value
3685 Lo := Type_Low_Bound (Typ);
3686 Hi := Type_High_Bound (Typ);
3688 LB_Known := Compile_Time_Known_Value (Lo);
3689 UB_Known := Compile_Time_Known_Value (Hi);
3691 -- Fixed point types should be considered as such only in
3692 -- flag Fixed_Int is set to False.
3694 if Is_Floating_Point_Type (Typ)
3695 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3698 Valr := Expr_Value_R (N);
3700 if LB_Known and then Valr >= Expr_Value_R (Lo)
3701 and then UB_Known and then Valr <= Expr_Value_R (Hi)
3709 Val := Expr_Value (N);
3711 if LB_Known and then Val >= Expr_Value (Lo)
3712 and then UB_Known and then Val <= Expr_Value (Hi)
3727 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3728 Typ : constant Entity_Id := Etype (Lo);
3731 if not Compile_Time_Known_Value (Lo)
3732 or else not Compile_Time_Known_Value (Hi)
3737 if Is_Discrete_Type (Typ) then
3738 return Expr_Value (Lo) > Expr_Value (Hi);
3741 pragma Assert (Is_Real_Type (Typ));
3742 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
3746 -----------------------------
3747 -- Is_OK_Static_Expression --
3748 -----------------------------
3750 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
3752 return Is_Static_Expression (N)
3753 and then not Raises_Constraint_Error (N);
3754 end Is_OK_Static_Expression;
3756 ------------------------
3757 -- Is_OK_Static_Range --
3758 ------------------------
3760 -- A static range is a range whose bounds are static expressions, or a
3761 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3762 -- We have already converted range attribute references, so we get the
3763 -- "or" part of this rule without needing a special test.
3765 function Is_OK_Static_Range (N : Node_Id) return Boolean is
3767 return Is_OK_Static_Expression (Low_Bound (N))
3768 and then Is_OK_Static_Expression (High_Bound (N));
3769 end Is_OK_Static_Range;
3771 --------------------------
3772 -- Is_OK_Static_Subtype --
3773 --------------------------
3775 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
3776 -- where neither bound raises constraint error when evaluated.
3778 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
3779 Base_T : constant Entity_Id := Base_Type (Typ);
3780 Anc_Subt : Entity_Id;
3783 -- First a quick check on the non static subtype flag. As described
3784 -- in further detail in Einfo, this flag is not decisive in all cases,
3785 -- but if it is set, then the subtype is definitely non-static.
3787 if Is_Non_Static_Subtype (Typ) then
3791 Anc_Subt := Ancestor_Subtype (Typ);
3793 if Anc_Subt = Empty then
3797 if Is_Generic_Type (Root_Type (Base_T))
3798 or else Is_Generic_Actual_Type (Base_T)
3804 elsif Is_String_Type (Typ) then
3806 Ekind (Typ) = E_String_Literal_Subtype
3808 (Is_OK_Static_Subtype (Component_Type (Typ))
3809 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
3813 elsif Is_Scalar_Type (Typ) then
3814 if Base_T = Typ then
3818 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so
3819 -- use Get_Type_Low,High_Bound.
3821 return Is_OK_Static_Subtype (Anc_Subt)
3822 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
3823 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
3826 -- Types other than string and scalar types are never static
3831 end Is_OK_Static_Subtype;
3833 ---------------------
3834 -- Is_Out_Of_Range --
3835 ---------------------
3837 function Is_Out_Of_Range
3840 Assume_Valid : Boolean := False;
3841 Fixed_Int : Boolean := False;
3842 Int_Real : Boolean := False) return Boolean
3847 pragma Warnings (Off, Assume_Valid);
3848 -- For now Assume_Valid is unreferenced since the current implementation
3849 -- always returns False if N is not a compile time known value, but we
3850 -- keep the parameter to allow for future enhancements in which we try
3851 -- to get the information in the variable case as well.
3854 -- Universal types have no range limits, so always in range
3856 if Typ = Universal_Integer or else Typ = Universal_Real then
3859 -- Never out of range if not scalar type. Don't know if this can
3860 -- actually happen, but our spec allows it, so we must check!
3862 elsif not Is_Scalar_Type (Typ) then
3865 -- Never out of range if this is a generic type, since the bounds
3866 -- of generic types are junk. Note that if we only checked for
3867 -- static expressions (instead of compile time known values) below,
3868 -- we would not need this check, because values of a generic type
3869 -- can never be static, but they can be known at compile time.
3871 elsif Is_Generic_Type (Typ) then
3874 -- Never out of range unless we have a compile time known value
3876 elsif not Compile_Time_Known_Value (N) then
3887 Lo := Type_Low_Bound (Typ);
3888 Hi := Type_High_Bound (Typ);
3890 LB_Known := Compile_Time_Known_Value (Lo);
3891 UB_Known := Compile_Time_Known_Value (Hi);
3893 -- Real types (note that fixed-point types are not treated
3894 -- as being of a real type if the flag Fixed_Int is set,
3895 -- since in that case they are regarded as integer types).
3897 if Is_Floating_Point_Type (Typ)
3898 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3901 Valr := Expr_Value_R (N);
3903 if LB_Known and then Valr < Expr_Value_R (Lo) then
3906 elsif UB_Known and then Expr_Value_R (Hi) < Valr then
3914 Val := Expr_Value (N);
3916 if LB_Known and then Val < Expr_Value (Lo) then
3919 elsif UB_Known and then Expr_Value (Hi) < Val then
3928 end Is_Out_Of_Range;
3930 ---------------------
3931 -- Is_Static_Range --
3932 ---------------------
3934 -- A static range is a range whose bounds are static expressions, or a
3935 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3936 -- We have already converted range attribute references, so we get the
3937 -- "or" part of this rule without needing a special test.
3939 function Is_Static_Range (N : Node_Id) return Boolean is
3941 return Is_Static_Expression (Low_Bound (N))
3942 and then Is_Static_Expression (High_Bound (N));
3943 end Is_Static_Range;
3945 -----------------------
3946 -- Is_Static_Subtype --
3947 -----------------------
3949 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
3951 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
3952 Base_T : constant Entity_Id := Base_Type (Typ);
3953 Anc_Subt : Entity_Id;
3956 -- First a quick check on the non static subtype flag. As described
3957 -- in further detail in Einfo, this flag is not decisive in all cases,
3958 -- but if it is set, then the subtype is definitely non-static.
3960 if Is_Non_Static_Subtype (Typ) then
3964 Anc_Subt := Ancestor_Subtype (Typ);
3966 if Anc_Subt = Empty then
3970 if Is_Generic_Type (Root_Type (Base_T))
3971 or else Is_Generic_Actual_Type (Base_T)
3977 elsif Is_String_Type (Typ) then
3979 Ekind (Typ) = E_String_Literal_Subtype
3981 (Is_Static_Subtype (Component_Type (Typ))
3982 and then Is_Static_Subtype (Etype (First_Index (Typ))));
3986 elsif Is_Scalar_Type (Typ) then
3987 if Base_T = Typ then
3991 return Is_Static_Subtype (Anc_Subt)
3992 and then Is_Static_Expression (Type_Low_Bound (Typ))
3993 and then Is_Static_Expression (Type_High_Bound (Typ));
3996 -- Types other than string and scalar types are never static
4001 end Is_Static_Subtype;
4003 --------------------
4004 -- Not_Null_Range --
4005 --------------------
4007 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4008 Typ : constant Entity_Id := Etype (Lo);
4011 if not Compile_Time_Known_Value (Lo)
4012 or else not Compile_Time_Known_Value (Hi)
4017 if Is_Discrete_Type (Typ) then
4018 return Expr_Value (Lo) <= Expr_Value (Hi);
4021 pragma Assert (Is_Real_Type (Typ));
4023 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
4031 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
4033 -- We allow a maximum of 500,000 bits which seems a reasonable limit
4035 if Bits < 500_000 then
4039 Error_Msg_N ("static value too large, capacity exceeded", N);
4048 procedure Out_Of_Range (N : Node_Id) is
4050 -- If we have the static expression case, then this is an illegality
4051 -- in Ada 95 mode, except that in an instance, we never generate an
4052 -- error (if the error is legitimate, it was already diagnosed in
4053 -- the template). The expression to compute the length of a packed
4054 -- array is attached to the array type itself, and deserves a separate
4057 if Is_Static_Expression (N)
4058 and then not In_Instance
4059 and then not In_Inlined_Body
4060 and then Ada_Version >= Ada_95
4062 if Nkind (Parent (N)) = N_Defining_Identifier
4063 and then Is_Array_Type (Parent (N))
4064 and then Present (Packed_Array_Type (Parent (N)))
4065 and then Present (First_Rep_Item (Parent (N)))
4068 ("length of packed array must not exceed Integer''Last",
4069 First_Rep_Item (Parent (N)));
4070 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
4073 Apply_Compile_Time_Constraint_Error
4074 (N, "value not in range of}", CE_Range_Check_Failed);
4077 -- Here we generate a warning for the Ada 83 case, or when we are
4078 -- in an instance, or when we have a non-static expression case.
4081 Apply_Compile_Time_Constraint_Error
4082 (N, "value not in range of}?", CE_Range_Check_Failed);
4086 -------------------------
4087 -- Rewrite_In_Raise_CE --
4088 -------------------------
4090 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
4091 Typ : constant Entity_Id := Etype (N);
4094 -- If we want to raise CE in the condition of a raise_CE node
4095 -- we may as well get rid of the condition
4097 if Present (Parent (N))
4098 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
4100 Set_Condition (Parent (N), Empty);
4102 -- If the expression raising CE is a N_Raise_CE node, we can use
4103 -- that one. We just preserve the type of the context
4105 elsif Nkind (Exp) = N_Raise_Constraint_Error then
4109 -- We have to build an explicit raise_ce node
4113 Make_Raise_Constraint_Error (Sloc (Exp),
4114 Reason => CE_Range_Check_Failed));
4115 Set_Raises_Constraint_Error (N);
4118 end Rewrite_In_Raise_CE;
4120 ---------------------
4121 -- String_Type_Len --
4122 ---------------------
4124 function String_Type_Len (Stype : Entity_Id) return Uint is
4125 NT : constant Entity_Id := Etype (First_Index (Stype));
4129 if Is_OK_Static_Subtype (NT) then
4132 T := Base_Type (NT);
4135 return Expr_Value (Type_High_Bound (T)) -
4136 Expr_Value (Type_Low_Bound (T)) + 1;
4137 end String_Type_Len;
4139 ------------------------------------
4140 -- Subtypes_Statically_Compatible --
4141 ------------------------------------
4143 function Subtypes_Statically_Compatible
4145 T2 : Entity_Id) return Boolean
4148 if Is_Scalar_Type (T1) then
4150 -- Definitely compatible if we match
4152 if Subtypes_Statically_Match (T1, T2) then
4155 -- If either subtype is nonstatic then they're not compatible
4157 elsif not Is_Static_Subtype (T1)
4158 or else not Is_Static_Subtype (T2)
4162 -- If either type has constraint error bounds, then consider that
4163 -- they match to avoid junk cascaded errors here.
4165 elsif not Is_OK_Static_Subtype (T1)
4166 or else not Is_OK_Static_Subtype (T2)
4170 -- Base types must match, but we don't check that (should
4171 -- we???) but we do at least check that both types are
4172 -- real, or both types are not real.
4174 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
4177 -- Here we check the bounds
4181 LB1 : constant Node_Id := Type_Low_Bound (T1);
4182 HB1 : constant Node_Id := Type_High_Bound (T1);
4183 LB2 : constant Node_Id := Type_Low_Bound (T2);
4184 HB2 : constant Node_Id := Type_High_Bound (T2);
4187 if Is_Real_Type (T1) then
4189 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4191 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4193 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4197 (Expr_Value (LB1) > Expr_Value (HB1))
4199 (Expr_Value (LB2) <= Expr_Value (LB1)
4201 Expr_Value (HB1) <= Expr_Value (HB2));
4206 elsif Is_Access_Type (T1) then
4207 return not Is_Constrained (T2)
4208 or else Subtypes_Statically_Match
4209 (Designated_Type (T1), Designated_Type (T2));
4212 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4213 or else Subtypes_Statically_Match (T1, T2);
4215 end Subtypes_Statically_Compatible;
4217 -------------------------------
4218 -- Subtypes_Statically_Match --
4219 -------------------------------
4221 -- Subtypes statically match if they have statically matching constraints
4222 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4223 -- they are the same identical constraint, or if they are static and the
4224 -- values match (RM 4.9.1(1)).
4226 function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
4228 -- A type always statically matches itself
4235 elsif Is_Scalar_Type (T1) then
4237 -- Base types must be the same
4239 if Base_Type (T1) /= Base_Type (T2) then
4243 -- A constrained numeric subtype never matches an unconstrained
4244 -- subtype, i.e. both types must be constrained or unconstrained.
4246 -- To understand the requirement for this test, see RM 4.9.1(1).
4247 -- As is made clear in RM 3.5.4(11), type Integer, for example
4248 -- is a constrained subtype with constraint bounds matching the
4249 -- bounds of its corresponding unconstrained base type. In this
4250 -- situation, Integer and Integer'Base do not statically match,
4251 -- even though they have the same bounds.
4253 -- We only apply this test to types in Standard and types that
4254 -- appear in user programs. That way, we do not have to be
4255 -- too careful about setting Is_Constrained right for itypes.
4257 if Is_Numeric_Type (T1)
4258 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4259 and then (Scope (T1) = Standard_Standard
4260 or else Comes_From_Source (T1))
4261 and then (Scope (T2) = Standard_Standard
4262 or else Comes_From_Source (T2))
4266 -- A generic scalar type does not statically match its base
4267 -- type (AI-311). In this case we make sure that the formals,
4268 -- which are first subtypes of their bases, are constrained.
4270 elsif Is_Generic_Type (T1)
4271 and then Is_Generic_Type (T2)
4272 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4277 -- If there was an error in either range, then just assume
4278 -- the types statically match to avoid further junk errors
4280 if Error_Posted (Scalar_Range (T1))
4282 Error_Posted (Scalar_Range (T2))
4287 -- Otherwise both types have bound that can be compared
4290 LB1 : constant Node_Id := Type_Low_Bound (T1);
4291 HB1 : constant Node_Id := Type_High_Bound (T1);
4292 LB2 : constant Node_Id := Type_Low_Bound (T2);
4293 HB2 : constant Node_Id := Type_High_Bound (T2);
4296 -- If the bounds are the same tree node, then match
4298 if LB1 = LB2 and then HB1 = HB2 then
4301 -- Otherwise bounds must be static and identical value
4304 if not Is_Static_Subtype (T1)
4305 or else not Is_Static_Subtype (T2)
4309 -- If either type has constraint error bounds, then say
4310 -- that they match to avoid junk cascaded errors here.
4312 elsif not Is_OK_Static_Subtype (T1)
4313 or else not Is_OK_Static_Subtype (T2)
4317 elsif Is_Real_Type (T1) then
4319 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4321 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4325 Expr_Value (LB1) = Expr_Value (LB2)
4327 Expr_Value (HB1) = Expr_Value (HB2);
4332 -- Type with discriminants
4334 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
4336 -- Because of view exchanges in multiple instantiations, conformance
4337 -- checking might try to match a partial view of a type with no
4338 -- discriminants with a full view that has defaulted discriminants.
4339 -- In such a case, use the discriminant constraint of the full view,
4340 -- which must exist because we know that the two subtypes have the
4343 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
4345 if Is_Private_Type (T2)
4346 and then Present (Full_View (T2))
4347 and then Has_Discriminants (Full_View (T2))
4349 return Subtypes_Statically_Match (T1, Full_View (T2));
4351 elsif Is_Private_Type (T1)
4352 and then Present (Full_View (T1))
4353 and then Has_Discriminants (Full_View (T1))
4355 return Subtypes_Statically_Match (Full_View (T1), T2);
4366 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
4367 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
4375 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
4379 -- Now loop through the discriminant constraints
4381 -- Note: the guard here seems necessary, since it is possible at
4382 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
4384 if Present (DL1) and then Present (DL2) then
4385 DA1 := First_Elmt (DL1);
4386 DA2 := First_Elmt (DL2);
4387 while Present (DA1) loop
4389 Expr1 : constant Node_Id := Node (DA1);
4390 Expr2 : constant Node_Id := Node (DA2);
4393 if not Is_Static_Expression (Expr1)
4394 or else not Is_Static_Expression (Expr2)
4398 -- If either expression raised a constraint error,
4399 -- consider the expressions as matching, since this
4400 -- helps to prevent cascading errors.
4402 elsif Raises_Constraint_Error (Expr1)
4403 or else Raises_Constraint_Error (Expr2)
4407 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
4420 -- A definite type does not match an indefinite or classwide type
4421 -- However, a generic type with unknown discriminants may be
4422 -- instantiated with a type with no discriminants, and conformance
4423 -- checking on an inherited operation may compare the actual with
4424 -- the subtype that renames it in the instance.
4427 Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
4430 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
4434 elsif Is_Array_Type (T1) then
4436 -- If either subtype is unconstrained then both must be,
4437 -- and if both are unconstrained then no further checking
4440 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
4441 return not (Is_Constrained (T1) or else Is_Constrained (T2));
4444 -- Both subtypes are constrained, so check that the index
4445 -- subtypes statically match.
4448 Index1 : Node_Id := First_Index (T1);
4449 Index2 : Node_Id := First_Index (T2);
4452 while Present (Index1) loop
4454 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
4459 Next_Index (Index1);
4460 Next_Index (Index2);
4466 elsif Is_Access_Type (T1) then
4467 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
4470 elsif Ekind (T1) = E_Access_Subprogram_Type
4471 or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type
4475 (Designated_Type (T1),
4476 Designated_Type (T2));
4479 Subtypes_Statically_Match
4480 (Designated_Type (T1),
4481 Designated_Type (T2))
4482 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
4485 -- All other types definitely match
4490 end Subtypes_Statically_Match;
4496 function Test (Cond : Boolean) return Uint is
4505 ---------------------------------
4506 -- Test_Expression_Is_Foldable --
4507 ---------------------------------
4511 procedure Test_Expression_Is_Foldable
4521 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4525 -- If operand is Any_Type, just propagate to result and do not
4526 -- try to fold, this prevents cascaded errors.
4528 if Etype (Op1) = Any_Type then
4529 Set_Etype (N, Any_Type);
4532 -- If operand raises constraint error, then replace node N with the
4533 -- raise constraint error node, and we are obviously not foldable.
4534 -- Note that this replacement inherits the Is_Static_Expression flag
4535 -- from the operand.
4537 elsif Raises_Constraint_Error (Op1) then
4538 Rewrite_In_Raise_CE (N, Op1);
4541 -- If the operand is not static, then the result is not static, and
4542 -- all we have to do is to check the operand since it is now known
4543 -- to appear in a non-static context.
4545 elsif not Is_Static_Expression (Op1) then
4546 Check_Non_Static_Context (Op1);
4547 Fold := Compile_Time_Known_Value (Op1);
4550 -- An expression of a formal modular type is not foldable because
4551 -- the modulus is unknown.
4553 elsif Is_Modular_Integer_Type (Etype (Op1))
4554 and then Is_Generic_Type (Etype (Op1))
4556 Check_Non_Static_Context (Op1);
4559 -- Here we have the case of an operand whose type is OK, which is
4560 -- static, and which does not raise constraint error, we can fold.
4563 Set_Is_Static_Expression (N);
4567 end Test_Expression_Is_Foldable;
4571 procedure Test_Expression_Is_Foldable
4578 Rstat : constant Boolean := Is_Static_Expression (Op1)
4579 and then Is_Static_Expression (Op2);
4585 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4589 -- If either operand is Any_Type, just propagate to result and
4590 -- do not try to fold, this prevents cascaded errors.
4592 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
4593 Set_Etype (N, Any_Type);
4596 -- If left operand raises constraint error, then replace node N with
4597 -- the raise constraint error node, and we are obviously not foldable.
4598 -- Is_Static_Expression is set from the two operands in the normal way,
4599 -- and we check the right operand if it is in a non-static context.
4601 elsif Raises_Constraint_Error (Op1) then
4603 Check_Non_Static_Context (Op2);
4606 Rewrite_In_Raise_CE (N, Op1);
4607 Set_Is_Static_Expression (N, Rstat);
4610 -- Similar processing for the case of the right operand. Note that
4611 -- we don't use this routine for the short-circuit case, so we do
4612 -- not have to worry about that special case here.
4614 elsif Raises_Constraint_Error (Op2) then
4616 Check_Non_Static_Context (Op1);
4619 Rewrite_In_Raise_CE (N, Op2);
4620 Set_Is_Static_Expression (N, Rstat);
4623 -- Exclude expressions of a generic modular type, as above
4625 elsif Is_Modular_Integer_Type (Etype (Op1))
4626 and then Is_Generic_Type (Etype (Op1))
4628 Check_Non_Static_Context (Op1);
4631 -- If result is not static, then check non-static contexts on operands
4632 -- since one of them may be static and the other one may not be static
4634 elsif not Rstat then
4635 Check_Non_Static_Context (Op1);
4636 Check_Non_Static_Context (Op2);
4637 Fold := Compile_Time_Known_Value (Op1)
4638 and then Compile_Time_Known_Value (Op2);
4641 -- Else result is static and foldable. Both operands are static,
4642 -- and neither raises constraint error, so we can definitely fold.
4645 Set_Is_Static_Expression (N);
4650 end Test_Expression_Is_Foldable;
4656 procedure To_Bits (U : Uint; B : out Bits) is
4658 for J in 0 .. B'Last loop
4659 B (J) := (U / (2 ** J)) mod 2 /= 0;
4663 --------------------
4664 -- Why_Not_Static --
4665 --------------------
4667 procedure Why_Not_Static (Expr : Node_Id) is
4668 N : constant Node_Id := Original_Node (Expr);
4672 procedure Why_Not_Static_List (L : List_Id);
4673 -- A version that can be called on a list of expressions. Finds
4674 -- all non-static violations in any element of the list.
4676 -------------------------
4677 -- Why_Not_Static_List --
4678 -------------------------
4680 procedure Why_Not_Static_List (L : List_Id) is
4684 if Is_Non_Empty_List (L) then
4686 while Present (N) loop
4691 end Why_Not_Static_List;
4693 -- Start of processing for Why_Not_Static
4696 -- If in ACATS mode (debug flag 2), then suppress all these
4697 -- messages, this avoids massive updates to the ACATS base line.
4699 if Debug_Flag_2 then
4703 -- Ignore call on error or empty node
4705 if No (Expr) or else Nkind (Expr) = N_Error then
4709 -- Preprocessing for sub expressions
4711 if Nkind (Expr) in N_Subexpr then
4713 -- Nothing to do if expression is static
4715 if Is_OK_Static_Expression (Expr) then
4719 -- Test for constraint error raised
4721 if Raises_Constraint_Error (Expr) then
4723 ("expression raises exception, cannot be static " &
4724 "(RM 4.9(34))!", N);
4728 -- If no type, then something is pretty wrong, so ignore
4730 Typ := Etype (Expr);
4736 -- Type must be scalar or string type
4738 if not Is_Scalar_Type (Typ)
4739 and then not Is_String_Type (Typ)
4742 ("static expression must have scalar or string type " &
4748 -- If we got through those checks, test particular node kind
4751 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
4754 if Is_Named_Number (E) then
4757 elsif Ekind (E) = E_Constant then
4758 if not Is_Static_Expression (Constant_Value (E)) then
4760 ("& is not a static constant (RM 4.9(5))!", N, E);
4765 ("& is not static constant or named number " &
4766 "(RM 4.9(5))!", N, E);
4769 when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
4770 if Nkind (N) in N_Op_Shift then
4772 ("shift functions are never static (RM 4.9(6,18))!", N);
4775 Why_Not_Static (Left_Opnd (N));
4776 Why_Not_Static (Right_Opnd (N));
4780 Why_Not_Static (Right_Opnd (N));
4782 when N_Attribute_Reference =>
4783 Why_Not_Static_List (Expressions (N));
4785 E := Etype (Prefix (N));
4787 if E = Standard_Void_Type then
4791 -- Special case non-scalar'Size since this is a common error
4793 if Attribute_Name (N) = Name_Size then
4795 ("size attribute is only static for scalar type " &
4796 "(RM 4.9(7,8))", N);
4800 elsif Is_Array_Type (E) then
4801 if Attribute_Name (N) /= Name_First
4803 Attribute_Name (N) /= Name_Last
4805 Attribute_Name (N) /= Name_Length
4808 ("static array attribute must be Length, First, or Last " &
4811 -- Since we know the expression is not-static (we already
4812 -- tested for this, must mean array is not static).
4816 ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
4821 -- Special case generic types, since again this is a common
4822 -- source of confusion.
4824 elsif Is_Generic_Actual_Type (E)
4829 ("attribute of generic type is never static " &
4830 "(RM 4.9(7,8))!", N);
4832 elsif Is_Static_Subtype (E) then
4835 elsif Is_Scalar_Type (E) then
4837 ("prefix type for attribute is not static scalar subtype " &
4842 ("static attribute must apply to array/scalar type " &
4843 "(RM 4.9(7,8))!", N);
4846 when N_String_Literal =>
4848 ("subtype of string literal is non-static (RM 4.9(4))!", N);
4850 when N_Explicit_Dereference =>
4852 ("explicit dereference is never static (RM 4.9)!", N);
4854 when N_Function_Call =>
4855 Why_Not_Static_List (Parameter_Associations (N));
4856 Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
4858 when N_Parameter_Association =>
4859 Why_Not_Static (Explicit_Actual_Parameter (N));
4861 when N_Indexed_Component =>
4863 ("indexed component is never static (RM 4.9)!", N);
4865 when N_Procedure_Call_Statement =>
4867 ("procedure call is never static (RM 4.9)!", N);
4869 when N_Qualified_Expression =>
4870 Why_Not_Static (Expression (N));
4872 when N_Aggregate | N_Extension_Aggregate =>
4874 ("an aggregate is never static (RM 4.9)!", N);
4877 Why_Not_Static (Low_Bound (N));
4878 Why_Not_Static (High_Bound (N));
4880 when N_Range_Constraint =>
4881 Why_Not_Static (Range_Expression (N));
4883 when N_Subtype_Indication =>
4884 Why_Not_Static (Constraint (N));
4886 when N_Selected_Component =>
4888 ("selected component is never static (RM 4.9)!", N);
4892 ("slice is never static (RM 4.9)!", N);
4894 when N_Type_Conversion =>
4895 Why_Not_Static (Expression (N));
4897 if not Is_Scalar_Type (Etype (Prefix (N)))
4898 or else not Is_Static_Subtype (Etype (Prefix (N)))
4901 ("static conversion requires static scalar subtype result " &
4905 when N_Unchecked_Type_Conversion =>
4907 ("unchecked type conversion is never static (RM 4.9)!", N);