File : sem_eval.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ E V A L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Eval_Fat; use Eval_Fat;
33 with Exp_Util; use Exp_Util;
34 with Freeze; use Freeze;
35 with Lib; use Lib;
36 with Namet; use Namet;
37 with Nmake; use Nmake;
38 with Nlists; use Nlists;
39 with Opt; use Opt;
40 with Par_SCO; use Par_SCO;
41 with Rtsfind; use Rtsfind;
42 with Sem; use Sem;
43 with Sem_Aux; use Sem_Aux;
44 with Sem_Cat; use Sem_Cat;
45 with Sem_Ch6; use Sem_Ch6;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Res; use Sem_Res;
48 with Sem_Util; use Sem_Util;
49 with Sem_Type; use Sem_Type;
50 with Sem_Warn; use Sem_Warn;
51 with Sinfo; use Sinfo;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Stringt; use Stringt;
55 with Tbuild; use Tbuild;
56
57 package body Sem_Eval is
58
59 -----------------------------------------
60 -- Handling of Compile Time Evaluation --
61 -----------------------------------------
62
63 -- The compile time evaluation of expressions is distributed over several
64 -- Eval_xxx procedures. These procedures are called immediately after
65 -- a subexpression is resolved and is therefore accomplished in a bottom
66 -- up fashion. The flags are synthesized using the following approach.
67
68 -- Is_Static_Expression is determined by following the detailed rules
69 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
70 -- flag of the operands in many cases.
71
72 -- Raises_Constraint_Error is set if any of the operands have the flag
73 -- set or if an attempt to compute the value of the current expression
74 -- results in detection of a runtime constraint error.
75
76 -- As described in the spec, the requirement is that Is_Static_Expression
77 -- be accurately set, and in addition for nodes for which this flag is set,
78 -- Raises_Constraint_Error must also be set. Furthermore a node which has
79 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
80 -- requirement is that the expression value must be precomputed, and the
81 -- node is either a literal, or the name of a constant entity whose value
82 -- is a static expression.
83
84 -- The general approach is as follows. First compute Is_Static_Expression.
85 -- If the node is not static, then the flag is left off in the node and
86 -- we are all done. Otherwise for a static node, we test if any of the
87 -- operands will raise constraint error, and if so, propagate the flag
88 -- Raises_Constraint_Error to the result node and we are done (since the
89 -- error was already posted at a lower level).
90
91 -- For the case of a static node whose operands do not raise constraint
92 -- error, we attempt to evaluate the node. If this evaluation succeeds,
93 -- then the node is replaced by the result of this computation. If the
94 -- evaluation raises constraint error, then we rewrite the node with
95 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
96 -- to post appropriate error messages.
97
98 ----------------
99 -- Local Data --
100 ----------------
101
102 type Bits is array (Nat range <>) of Boolean;
103 -- Used to convert unsigned (modular) values for folding logical ops
104
105 -- The following declarations are used to maintain a cache of nodes that
106 -- have compile time known values. The cache is maintained only for
107 -- discrete types (the most common case), and is populated by calls to
108 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
109 -- since it is possible for the status to change (in particular it is
110 -- possible for a node to get replaced by a constraint error node).
111
112 CV_Bits : constant := 5;
113 -- Number of low order bits of Node_Id value used to reference entries
114 -- in the cache table.
115
116 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
117 -- Size of cache for compile time values
118
119 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
120
121 type CV_Entry is record
122 N : Node_Id;
123 V : Uint;
124 end record;
125
126 type Match_Result is (Match, No_Match, Non_Static);
127 -- Result returned from functions that test for a matching result. If the
128 -- operands are not OK_Static then Non_Static will be returned. Otherwise
129 -- Match/No_Match is returned depending on whether the match succeeds.
130
131 type CV_Cache_Array is array (CV_Range) of CV_Entry;
132
133 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
134 -- This is the actual cache, with entries consisting of node/value pairs,
135 -- and the impossible value Node_High_Bound used for unset entries.
136
137 type Range_Membership is (In_Range, Out_Of_Range, Unknown);
138 -- Range membership may either be statically known to be in range or out
139 -- of range, or not statically known. Used for Test_In_Range below.
140
141 -----------------------
142 -- Local Subprograms --
143 -----------------------
144
145 function Choice_Matches
146 (Expr : Node_Id;
147 Choice : Node_Id) return Match_Result;
148 -- Determines whether given value Expr matches the given Choice. The Expr
149 -- can be of discrete, real, or string type and must be a compile time
150 -- known value (it is an error to make the call if these conditions are
151 -- not met). The choice can be a range, subtype name, subtype indication,
152 -- or expression. The returned result is Non_Static if Choice is not
153 -- OK_Static, otherwise either Match or No_Match is returned depending
154 -- on whether Choice matches Expr. This is used for case expression
155 -- alternatives, and also for membership tests. In each case, more
156 -- possibilities are tested than the syntax allows (e.g. membership allows
157 -- subtype indications and non-discrete types, and case allows an OTHERS
158 -- choice), but it does not matter, since we have already done a full
159 -- semantic and syntax check of the construct, so the extra possibilities
160 -- just will not arise for correct expressions.
161 --
162 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
163 -- a reference to a type, one of whose bounds raises Constraint_Error, then
164 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
165
166 function Choices_Match
167 (Expr : Node_Id;
168 Choices : List_Id) return Match_Result;
169 -- This function applies Choice_Matches to each element of Choices. If the
170 -- result is No_Match, then it continues and checks the next element. If
171 -- the result is Match or Non_Static, this result is immediately given
172 -- as the result without checking the rest of the list. Expr can be of
173 -- discrete, real, or string type and must be a compile time known value
174 -- (it is an error to make the call if these conditions are not met).
175
176 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
177 -- Check whether an arithmetic operation with universal operands which is a
178 -- rewritten function call with an explicit scope indication is ambiguous:
179 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
180 -- type declared in P and the context does not impose a type on the result
181 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
182 -- error and return Empty, else return the result type of the operator.
183
184 function From_Bits (B : Bits; T : Entity_Id) return Uint;
185 -- Converts a bit string of length B'Length to a Uint value to be used for
186 -- a target of type T, which is a modular type. This procedure includes the
187 -- necessary reduction by the modulus in the case of a nonbinary modulus
188 -- (for a binary modulus, the bit string is the right length any way so all
189 -- is well).
190
191 function Get_String_Val (N : Node_Id) return Node_Id;
192 -- Given a tree node for a folded string or character value, returns the
193 -- corresponding string literal or character literal (one of the two must
194 -- be available, or the operand would not have been marked as foldable in
195 -- the earlier analysis of the operation).
196
197 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
198 -- Given a choice (from a case expression or membership test), returns
199 -- True if the choice is static and does not raise a Constraint_Error.
200
201 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean;
202 -- Given a choice list (from a case expression or membership test), return
203 -- True if all choices are static in the sense of Is_OK_Static_Choice.
204
205 function Is_Static_Choice (Choice : Node_Id) return Boolean;
206 -- Given a choice (from a case expression or membership test), returns
207 -- True if the choice is static. No test is made for raising of constraint
208 -- error, so this function is used only for legality tests.
209
210 function Is_Static_Choice_List (Choices : List_Id) return Boolean;
211 -- Given a choice list (from a case expression or membership test), return
212 -- True if all choices are static in the sense of Is_Static_Choice.
213
214 function Is_Static_Range (N : Node_Id) return Boolean;
215 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
216 -- argument is an N_Range node (but note that the semantic analysis of
217 -- equivalent range attribute references already turned them into the
218 -- equivalent range). This differs from Is_OK_Static_Range (which is what
219 -- must be used by clients) in that it does not care whether the bounds
220 -- raise Constraint_Error or not. Used for checking whether expressions are
221 -- static in the 4.9 sense (without worrying about exceptions).
222
223 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
224 -- Bits represents the number of bits in an integer value to be computed
225 -- (but the value has not been computed yet). If this value in Bits is
226 -- reasonable, a result of True is returned, with the implication that the
227 -- caller should go ahead and complete the calculation. If the value in
228 -- Bits is unreasonably large, then an error is posted on node N, and
229 -- False is returned (and the caller skips the proposed calculation).
230
231 procedure Out_Of_Range (N : Node_Id);
232 -- This procedure is called if it is determined that node N, which appears
233 -- in a non-static context, is a compile time known value which is outside
234 -- its range, i.e. the range of Etype. This is used in contexts where
235 -- this is an illegality if N is static, and should generate a warning
236 -- otherwise.
237
238 function Real_Or_String_Static_Predicate_Matches
239 (Val : Node_Id;
240 Typ : Entity_Id) return Boolean;
241 -- This is the function used to evaluate real or string static predicates.
242 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
243 -- represents the value to be tested against the predicate. Typ is the
244 -- type with the predicate, from which the predicate expression can be
245 -- extracted. The result returned is True if the given value satisfies
246 -- the predicate.
247
248 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
249 -- N and Exp are nodes representing an expression, Exp is known to raise
250 -- CE. N is rewritten in term of Exp in the optimal way.
251
252 function String_Type_Len (Stype : Entity_Id) return Uint;
253 -- Given a string type, determines the length of the index type, or, if
254 -- this index type is non-static, the length of the base type of this index
255 -- type. Note that if the string type is itself static, then the index type
256 -- is static, so the second case applies only if the string type passed is
257 -- non-static.
258
259 function Test (Cond : Boolean) return Uint;
260 pragma Inline (Test);
261 -- This function simply returns the appropriate Boolean'Pos value
262 -- corresponding to the value of Cond as a universal integer. It is
263 -- used for producing the result of the static evaluation of the
264 -- logical operators
265
266 procedure Test_Expression_Is_Foldable
267 (N : Node_Id;
268 Op1 : Node_Id;
269 Stat : out Boolean;
270 Fold : out Boolean);
271 -- Tests to see if expression N whose single operand is Op1 is foldable,
272 -- i.e. the operand value is known at compile time. If the operation is
273 -- foldable, then Fold is True on return, and Stat indicates whether the
274 -- result is static (i.e. the operand was static). Note that it is quite
275 -- possible for Fold to be True, and Stat to be False, since there are
276 -- cases in which we know the value of an operand even though it is not
277 -- technically static (e.g. the static lower bound of a range whose upper
278 -- bound is non-static).
279 --
280 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
281 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
282 -- return, then all processing is complete, and the caller should return,
283 -- since there is nothing else to do.
284 --
285 -- If Stat is set True on return, then Is_Static_Expression is also set
286 -- true in node N. There are some cases where this is over-enthusiastic,
287 -- e.g. in the two operand case below, for string comparison, the result is
288 -- not static even though the two operands are static. In such cases, the
289 -- caller must reset the Is_Static_Expression flag in N.
290 --
291 -- If Fold and Stat are both set to False then this routine performs also
292 -- the following extra actions:
293 --
294 -- If either operand is Any_Type then propagate it to result to prevent
295 -- cascaded errors.
296 --
297 -- If some operand raises constraint error, then replace the node N
298 -- with the raise constraint error node. This replacement inherits the
299 -- Is_Static_Expression flag from the operands.
300
301 procedure Test_Expression_Is_Foldable
302 (N : Node_Id;
303 Op1 : Node_Id;
304 Op2 : Node_Id;
305 Stat : out Boolean;
306 Fold : out Boolean;
307 CRT_Safe : Boolean := False);
308 -- Same processing, except applies to an expression N with two operands
309 -- Op1 and Op2. The result is static only if both operands are static. If
310 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
311 -- for the tests that the two operands are known at compile time. See
312 -- spec of this routine for further details.
313
314 function Test_In_Range
315 (N : Node_Id;
316 Typ : Entity_Id;
317 Assume_Valid : Boolean;
318 Fixed_Int : Boolean;
319 Int_Real : Boolean) return Range_Membership;
320 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
321 -- or Out_Of_Range if it can be guaranteed at compile time that expression
322 -- N is known to be in or out of range of the subtype Typ. If not compile
323 -- time known, Unknown is returned. See documentation of Is_In_Range for
324 -- complete description of parameters.
325
326 procedure To_Bits (U : Uint; B : out Bits);
327 -- Converts a Uint value to a bit string of length B'Length
328
329 -----------------------------------------------
330 -- Check_Expression_Against_Static_Predicate --
331 -----------------------------------------------
332
333 procedure Check_Expression_Against_Static_Predicate
334 (Expr : Node_Id;
335 Typ : Entity_Id)
336 is
337 begin
338 -- Nothing to do if expression is not known at compile time, or the
339 -- type has no static predicate set (will be the case for all non-scalar
340 -- types, so no need to make a special test for that).
341
342 if not (Has_Static_Predicate (Typ)
343 and then Compile_Time_Known_Value (Expr))
344 then
345 return;
346 end if;
347
348 -- Here we have a static predicate (note that it could have arisen from
349 -- an explicitly specified Dynamic_Predicate whose expression met the
350 -- rules for being predicate-static).
351
352 -- Case of real static predicate
353
354 if Is_Real_Type (Typ) then
355 if Real_Or_String_Static_Predicate_Matches
356 (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
357 Typ => Typ)
358 then
359 return;
360 end if;
361
362 -- Case of string static predicate
363
364 elsif Is_String_Type (Typ) then
365 if Real_Or_String_Static_Predicate_Matches
366 (Val => Expr_Value_S (Expr), Typ => Typ)
367 then
368 return;
369 end if;
370
371 -- Case of discrete static predicate
372
373 else
374 pragma Assert (Is_Discrete_Type (Typ));
375
376 -- If static predicate matches, nothing to do
377
378 if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
379 return;
380 end if;
381 end if;
382
383 -- Here we know that the predicate will fail
384
385 -- Special case of static expression failing a predicate (other than one
386 -- that was explicitly specified with a Dynamic_Predicate aspect). This
387 -- is the case where the expression is no longer considered static.
388
389 if Is_Static_Expression (Expr)
390 and then not Has_Dynamic_Predicate_Aspect (Typ)
391 then
392 Error_Msg_NE
393 ("??static expression fails static predicate check on &",
394 Expr, Typ);
395 Error_Msg_N
396 ("\??expression is no longer considered static", Expr);
397 Set_Is_Static_Expression (Expr, False);
398
399 -- In all other cases, this is just a warning that a test will fail.
400 -- It does not matter if the expression is static or not, or if the
401 -- predicate comes from a dynamic predicate aspect or not.
402
403 else
404 Error_Msg_NE
405 ("??expression fails predicate check on &", Expr, Typ);
406 end if;
407 end Check_Expression_Against_Static_Predicate;
408
409 ------------------------------
410 -- Check_Non_Static_Context --
411 ------------------------------
412
413 procedure Check_Non_Static_Context (N : Node_Id) is
414 T : constant Entity_Id := Etype (N);
415 Checks_On : constant Boolean :=
416 not Index_Checks_Suppressed (T)
417 and not Range_Checks_Suppressed (T);
418
419 begin
420 -- Ignore cases of non-scalar types, error types, or universal real
421 -- types that have no usable bounds.
422
423 if T = Any_Type
424 or else not Is_Scalar_Type (T)
425 or else T = Universal_Fixed
426 or else T = Universal_Real
427 then
428 return;
429 end if;
430
431 -- At this stage we have a scalar type. If we have an expression that
432 -- raises CE, then we already issued a warning or error msg so there is
433 -- nothing more to be done in this routine.
434
435 if Raises_Constraint_Error (N) then
436 return;
437 end if;
438
439 -- Now we have a scalar type which is not marked as raising a constraint
440 -- error exception. The main purpose of this routine is to deal with
441 -- static expressions appearing in a non-static context. That means
442 -- that if we do not have a static expression then there is not much
443 -- to do. The one case that we deal with here is that if we have a
444 -- floating-point value that is out of range, then we post a warning
445 -- that an infinity will result.
446
447 if not Is_Static_Expression (N) then
448 if Is_Floating_Point_Type (T)
449 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
450 then
451 Error_Msg_N
452 ("??float value out of range, infinity will be generated", N);
453 end if;
454
455 return;
456 end if;
457
458 -- Here we have the case of outer level static expression of scalar
459 -- type, where the processing of this procedure is needed.
460
461 -- For real types, this is where we convert the value to a machine
462 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
463 -- need to do this if the parent is a constant declaration, since in
464 -- other cases, gigi should do the necessary conversion correctly, but
465 -- experimentation shows that this is not the case on all machines, in
466 -- particular if we do not convert all literals to machine values in
467 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
468 -- and SGI/Irix.
469
470 -- This conversion is always done by GNATprove on real literals in
471 -- non-static expressions, by calling Check_Non_Static_Context from
472 -- gnat2why, as GNATprove cannot do the conversion later contrary
473 -- to gigi. The frontend computes the information about which
474 -- expressions are static, which is used by gnat2why to call
475 -- Check_Non_Static_Context on exactly those real literals that are
476 -- not sub-expressions of static expressions.
477
478 if Nkind (N) = N_Real_Literal
479 and then not Is_Machine_Number (N)
480 and then not Is_Generic_Type (Etype (N))
481 and then Etype (N) /= Universal_Real
482 then
483 -- Check that value is in bounds before converting to machine
484 -- number, so as not to lose case where value overflows in the
485 -- least significant bit or less. See B490001.
486
487 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
488 Out_Of_Range (N);
489 return;
490 end if;
491
492 -- Note: we have to copy the node, to avoid problems with conformance
493 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
494
495 Rewrite (N, New_Copy (N));
496
497 if not Is_Floating_Point_Type (T) then
498 Set_Realval
499 (N, Corresponding_Integer_Value (N) * Small_Value (T));
500
501 elsif not UR_Is_Zero (Realval (N)) then
502
503 -- Note: even though RM 4.9(38) specifies biased rounding, this
504 -- has been modified by AI-100 in order to prevent confusing
505 -- differences in rounding between static and non-static
506 -- expressions. AI-100 specifies that the effect of such rounding
507 -- is implementation dependent, and in GNAT we round to nearest
508 -- even to match the run-time behavior. Note that this applies
509 -- to floating point literals, not fixed points ones, even though
510 -- their compiler representation is also as a universal real.
511
512 Set_Realval
513 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
514 Set_Is_Machine_Number (N);
515 end if;
516
517 end if;
518
519 -- Check for out of range universal integer. This is a non-static
520 -- context, so the integer value must be in range of the runtime
521 -- representation of universal integers.
522
523 -- We do this only within an expression, because that is the only
524 -- case in which non-static universal integer values can occur, and
525 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
526 -- called in contexts like the expression of a number declaration where
527 -- we certainly want to allow out of range values.
528
529 if Etype (N) = Universal_Integer
530 and then Nkind (N) = N_Integer_Literal
531 and then Nkind (Parent (N)) in N_Subexpr
532 and then
533 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
534 or else
535 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
536 then
537 Apply_Compile_Time_Constraint_Error
538 (N, "non-static universal integer value out of range<<",
539 CE_Range_Check_Failed);
540
541 -- Check out of range of base type
542
543 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
544 Out_Of_Range (N);
545
546 -- Give warning if outside subtype (where one or both of the bounds of
547 -- the subtype is static). This warning is omitted if the expression
548 -- appears in a range that could be null (warnings are handled elsewhere
549 -- for this case).
550
551 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
552 if Is_In_Range (N, T, Assume_Valid => True) then
553 null;
554
555 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
556 Apply_Compile_Time_Constraint_Error
557 (N, "value not in range of}<<", CE_Range_Check_Failed);
558
559 elsif Checks_On then
560 Enable_Range_Check (N);
561
562 else
563 Set_Do_Range_Check (N, False);
564 end if;
565 end if;
566 end Check_Non_Static_Context;
567
568 ---------------------------------
569 -- Check_String_Literal_Length --
570 ---------------------------------
571
572 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
573 begin
574 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
575 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
576 then
577 Apply_Compile_Time_Constraint_Error
578 (N, "string length wrong for}??",
579 CE_Length_Check_Failed,
580 Ent => Ttype,
581 Typ => Ttype);
582 end if;
583 end if;
584 end Check_String_Literal_Length;
585
586 --------------------
587 -- Choice_Matches --
588 --------------------
589
590 function Choice_Matches
591 (Expr : Node_Id;
592 Choice : Node_Id) return Match_Result
593 is
594 Etyp : constant Entity_Id := Etype (Expr);
595 Val : Uint;
596 ValR : Ureal;
597 ValS : Node_Id;
598
599 begin
600 pragma Assert (Compile_Time_Known_Value (Expr));
601 pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
602
603 if not Is_OK_Static_Choice (Choice) then
604 Set_Raises_Constraint_Error (Choice);
605 return Non_Static;
606
607 -- When the choice denotes a subtype with a static predictate, check the
608 -- expression against the predicate values.
609
610 elsif (Nkind (Choice) = N_Subtype_Indication
611 or else (Is_Entity_Name (Choice)
612 and then Is_Type (Entity (Choice))))
613 and then Has_Predicates (Etype (Choice))
614 and then Has_Static_Predicate (Etype (Choice))
615 then
616 return
617 Choices_Match (Expr, Static_Discrete_Predicate (Etype (Choice)));
618
619 -- Discrete type case
620
621 elsif Is_Discrete_Type (Etyp) then
622 Val := Expr_Value (Expr);
623
624 if Nkind (Choice) = N_Range then
625 if Val >= Expr_Value (Low_Bound (Choice))
626 and then
627 Val <= Expr_Value (High_Bound (Choice))
628 then
629 return Match;
630 else
631 return No_Match;
632 end if;
633
634 elsif Nkind (Choice) = N_Subtype_Indication
635 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
636 then
637 if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
638 and then
639 Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
640 then
641 return Match;
642 else
643 return No_Match;
644 end if;
645
646 elsif Nkind (Choice) = N_Others_Choice then
647 return Match;
648
649 else
650 if Val = Expr_Value (Choice) then
651 return Match;
652 else
653 return No_Match;
654 end if;
655 end if;
656
657 -- Real type case
658
659 elsif Is_Real_Type (Etyp) then
660 ValR := Expr_Value_R (Expr);
661
662 if Nkind (Choice) = N_Range then
663 if ValR >= Expr_Value_R (Low_Bound (Choice))
664 and then
665 ValR <= Expr_Value_R (High_Bound (Choice))
666 then
667 return Match;
668 else
669 return No_Match;
670 end if;
671
672 elsif Nkind (Choice) = N_Subtype_Indication
673 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
674 then
675 if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
676 and then
677 ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
678 then
679 return Match;
680 else
681 return No_Match;
682 end if;
683
684 else
685 if ValR = Expr_Value_R (Choice) then
686 return Match;
687 else
688 return No_Match;
689 end if;
690 end if;
691
692 -- String type cases
693
694 else
695 pragma Assert (Is_String_Type (Etyp));
696 ValS := Expr_Value_S (Expr);
697
698 if Nkind (Choice) = N_Subtype_Indication
699 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
700 then
701 if not Is_Constrained (Etype (Choice)) then
702 return Match;
703
704 else
705 declare
706 Typlen : constant Uint :=
707 String_Type_Len (Etype (Choice));
708 Strlen : constant Uint :=
709 UI_From_Int (String_Length (Strval (ValS)));
710 begin
711 if Typlen = Strlen then
712 return Match;
713 else
714 return No_Match;
715 end if;
716 end;
717 end if;
718
719 else
720 if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
721 then
722 return Match;
723 else
724 return No_Match;
725 end if;
726 end if;
727 end if;
728 end Choice_Matches;
729
730 -------------------
731 -- Choices_Match --
732 -------------------
733
734 function Choices_Match
735 (Expr : Node_Id;
736 Choices : List_Id) return Match_Result
737 is
738 Choice : Node_Id;
739 Result : Match_Result;
740
741 begin
742 Choice := First (Choices);
743 while Present (Choice) loop
744 Result := Choice_Matches (Expr, Choice);
745
746 if Result /= No_Match then
747 return Result;
748 end if;
749
750 Next (Choice);
751 end loop;
752
753 return No_Match;
754 end Choices_Match;
755
756 --------------------------
757 -- Compile_Time_Compare --
758 --------------------------
759
760 function Compile_Time_Compare
761 (L, R : Node_Id;
762 Assume_Valid : Boolean) return Compare_Result
763 is
764 Discard : aliased Uint;
765 begin
766 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
767 end Compile_Time_Compare;
768
769 function Compile_Time_Compare
770 (L, R : Node_Id;
771 Diff : access Uint;
772 Assume_Valid : Boolean;
773 Rec : Boolean := False) return Compare_Result
774 is
775 Ltyp : Entity_Id := Etype (L);
776 Rtyp : Entity_Id := Etype (R);
777
778 Discard : aliased Uint;
779
780 procedure Compare_Decompose
781 (N : Node_Id;
782 R : out Node_Id;
783 V : out Uint);
784 -- This procedure decomposes the node N into an expression node and a
785 -- signed offset, so that the value of N is equal to the value of R plus
786 -- the value V (which may be negative). If no such decomposition is
787 -- possible, then on return R is a copy of N, and V is set to zero.
788
789 function Compare_Fixup (N : Node_Id) return Node_Id;
790 -- This function deals with replacing 'Last and 'First references with
791 -- their corresponding type bounds, which we then can compare. The
792 -- argument is the original node, the result is the identity, unless we
793 -- have a 'Last/'First reference in which case the value returned is the
794 -- appropriate type bound.
795
796 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
797 -- Even if the context does not assume that values are valid, some
798 -- simple cases can be recognized.
799
800 function Is_Same_Value (L, R : Node_Id) return Boolean;
801 -- Returns True iff L and R represent expressions that definitely have
802 -- identical (but not necessarily compile time known) values Indeed the
803 -- caller is expected to have already dealt with the cases of compile
804 -- time known values, so these are not tested here.
805
806 -----------------------
807 -- Compare_Decompose --
808 -----------------------
809
810 procedure Compare_Decompose
811 (N : Node_Id;
812 R : out Node_Id;
813 V : out Uint)
814 is
815 begin
816 if Nkind (N) = N_Op_Add
817 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
818 then
819 R := Left_Opnd (N);
820 V := Intval (Right_Opnd (N));
821 return;
822
823 elsif Nkind (N) = N_Op_Subtract
824 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
825 then
826 R := Left_Opnd (N);
827 V := UI_Negate (Intval (Right_Opnd (N)));
828 return;
829
830 elsif Nkind (N) = N_Attribute_Reference then
831 if Attribute_Name (N) = Name_Succ then
832 R := First (Expressions (N));
833 V := Uint_1;
834 return;
835
836 elsif Attribute_Name (N) = Name_Pred then
837 R := First (Expressions (N));
838 V := Uint_Minus_1;
839 return;
840 end if;
841 end if;
842
843 R := N;
844 V := Uint_0;
845 end Compare_Decompose;
846
847 -------------------
848 -- Compare_Fixup --
849 -------------------
850
851 function Compare_Fixup (N : Node_Id) return Node_Id is
852 Indx : Node_Id;
853 Xtyp : Entity_Id;
854 Subs : Nat;
855
856 begin
857 -- Fixup only required for First/Last attribute reference
858
859 if Nkind (N) = N_Attribute_Reference
860 and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
861 then
862 Xtyp := Etype (Prefix (N));
863
864 -- If we have no type, then just abandon the attempt to do
865 -- a fixup, this is probably the result of some other error.
866
867 if No (Xtyp) then
868 return N;
869 end if;
870
871 -- Dereference an access type
872
873 if Is_Access_Type (Xtyp) then
874 Xtyp := Designated_Type (Xtyp);
875 end if;
876
877 -- If we don't have an array type at this stage, something is
878 -- peculiar, e.g. another error, and we abandon the attempt at
879 -- a fixup.
880
881 if not Is_Array_Type (Xtyp) then
882 return N;
883 end if;
884
885 -- Ignore unconstrained array, since bounds are not meaningful
886
887 if not Is_Constrained (Xtyp) then
888 return N;
889 end if;
890
891 if Ekind (Xtyp) = E_String_Literal_Subtype then
892 if Attribute_Name (N) = Name_First then
893 return String_Literal_Low_Bound (Xtyp);
894 else
895 return
896 Make_Integer_Literal (Sloc (N),
897 Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
898 String_Literal_Length (Xtyp));
899 end if;
900 end if;
901
902 -- Find correct index type
903
904 Indx := First_Index (Xtyp);
905
906 if Present (Expressions (N)) then
907 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
908
909 for J in 2 .. Subs loop
910 Indx := Next_Index (Indx);
911 end loop;
912 end if;
913
914 Xtyp := Etype (Indx);
915
916 if Attribute_Name (N) = Name_First then
917 return Type_Low_Bound (Xtyp);
918 else
919 return Type_High_Bound (Xtyp);
920 end if;
921 end if;
922
923 return N;
924 end Compare_Fixup;
925
926 ----------------------------
927 -- Is_Known_Valid_Operand --
928 ----------------------------
929
930 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
931 begin
932 return (Is_Entity_Name (Opnd)
933 and then
934 (Is_Known_Valid (Entity (Opnd))
935 or else Ekind (Entity (Opnd)) = E_In_Parameter
936 or else
937 (Ekind (Entity (Opnd)) in Object_Kind
938 and then Present (Current_Value (Entity (Opnd))))))
939 or else Is_OK_Static_Expression (Opnd);
940 end Is_Known_Valid_Operand;
941
942 -------------------
943 -- Is_Same_Value --
944 -------------------
945
946 function Is_Same_Value (L, R : Node_Id) return Boolean is
947 Lf : constant Node_Id := Compare_Fixup (L);
948 Rf : constant Node_Id := Compare_Fixup (R);
949
950 function Is_Same_Subscript (L, R : List_Id) return Boolean;
951 -- L, R are the Expressions values from two attribute nodes for First
952 -- or Last attributes. Either may be set to No_List if no expressions
953 -- are present (indicating subscript 1). The result is True if both
954 -- expressions represent the same subscript (note one case is where
955 -- one subscript is missing and the other is explicitly set to 1).
956
957 -----------------------
958 -- Is_Same_Subscript --
959 -----------------------
960
961 function Is_Same_Subscript (L, R : List_Id) return Boolean is
962 begin
963 if L = No_List then
964 if R = No_List then
965 return True;
966 else
967 return Expr_Value (First (R)) = Uint_1;
968 end if;
969
970 else
971 if R = No_List then
972 return Expr_Value (First (L)) = Uint_1;
973 else
974 return Expr_Value (First (L)) = Expr_Value (First (R));
975 end if;
976 end if;
977 end Is_Same_Subscript;
978
979 -- Start of processing for Is_Same_Value
980
981 begin
982 -- Values are the same if they refer to the same entity and the
983 -- entity is non-volatile. This does not however apply to Float
984 -- types, since we may have two NaN values and they should never
985 -- compare equal.
986
987 -- If the entity is a discriminant, the two expressions may be bounds
988 -- of components of objects of the same discriminated type. The
989 -- values of the discriminants are not static, and therefore the
990 -- result is unknown.
991
992 -- It would be better to comment individual branches of this test ???
993
994 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
995 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
996 and then Entity (Lf) = Entity (Rf)
997 and then Ekind (Entity (Lf)) /= E_Discriminant
998 and then Present (Entity (Lf))
999 and then not Is_Floating_Point_Type (Etype (L))
1000 and then not Is_Volatile_Reference (L)
1001 and then not Is_Volatile_Reference (R)
1002 then
1003 return True;
1004
1005 -- Or if they are compile time known and identical
1006
1007 elsif Compile_Time_Known_Value (Lf)
1008 and then
1009 Compile_Time_Known_Value (Rf)
1010 and then Expr_Value (Lf) = Expr_Value (Rf)
1011 then
1012 return True;
1013
1014 -- False if Nkind of the two nodes is different for remaining cases
1015
1016 elsif Nkind (Lf) /= Nkind (Rf) then
1017 return False;
1018
1019 -- True if both 'First or 'Last values applying to the same entity
1020 -- (first and last don't change even if value does). Note that we
1021 -- need this even with the calls to Compare_Fixup, to handle the
1022 -- case of unconstrained array attributes where Compare_Fixup
1023 -- cannot find useful bounds.
1024
1025 elsif Nkind (Lf) = N_Attribute_Reference
1026 and then Attribute_Name (Lf) = Attribute_Name (Rf)
1027 and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
1028 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
1029 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
1030 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
1031 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
1032 then
1033 return True;
1034
1035 -- True if the same selected component from the same record
1036
1037 elsif Nkind (Lf) = N_Selected_Component
1038 and then Selector_Name (Lf) = Selector_Name (Rf)
1039 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
1040 then
1041 return True;
1042
1043 -- True if the same unary operator applied to the same operand
1044
1045 elsif Nkind (Lf) in N_Unary_Op
1046 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1047 then
1048 return True;
1049
1050 -- True if the same binary operator applied to the same operands
1051
1052 elsif Nkind (Lf) in N_Binary_Op
1053 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
1054 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1055 then
1056 return True;
1057
1058 -- All other cases, we can't tell, so return False
1059
1060 else
1061 return False;
1062 end if;
1063 end Is_Same_Value;
1064
1065 -- Start of processing for Compile_Time_Compare
1066
1067 begin
1068 Diff.all := No_Uint;
1069
1070 -- In preanalysis mode, always return Unknown unless the expression
1071 -- is static. It is too early to be thinking we know the result of a
1072 -- comparison, save that judgment for the full analysis. This is
1073 -- particularly important in the case of pre and postconditions, which
1074 -- otherwise can be prematurely collapsed into having True or False
1075 -- conditions when this is inappropriate.
1076
1077 if not (Full_Analysis
1078 or else (Is_OK_Static_Expression (L)
1079 and then
1080 Is_OK_Static_Expression (R)))
1081 then
1082 return Unknown;
1083 end if;
1084
1085 -- If either operand could raise constraint error, then we cannot
1086 -- know the result at compile time (since CE may be raised).
1087
1088 if not (Cannot_Raise_Constraint_Error (L)
1089 and then
1090 Cannot_Raise_Constraint_Error (R))
1091 then
1092 return Unknown;
1093 end if;
1094
1095 -- Identical operands are most certainly equal
1096
1097 if L = R then
1098 return EQ;
1099 end if;
1100
1101 -- If expressions have no types, then do not attempt to determine if
1102 -- they are the same, since something funny is going on. One case in
1103 -- which this happens is during generic template analysis, when bounds
1104 -- are not fully analyzed.
1105
1106 if No (Ltyp) or else No (Rtyp) then
1107 return Unknown;
1108 end if;
1109
1110 -- These get reset to the base type for the case of entities where
1111 -- Is_Known_Valid is not set. This takes care of handling possible
1112 -- invalid representations using the value of the base type, in
1113 -- accordance with RM 13.9.1(10).
1114
1115 Ltyp := Underlying_Type (Ltyp);
1116 Rtyp := Underlying_Type (Rtyp);
1117
1118 -- Same rationale as above, but for Underlying_Type instead of Etype
1119
1120 if No (Ltyp) or else No (Rtyp) then
1121 return Unknown;
1122 end if;
1123
1124 -- We do not attempt comparisons for packed arrays arrays represented as
1125 -- modular types, where the semantics of comparison is quite different.
1126
1127 if Is_Packed_Array_Impl_Type (Ltyp)
1128 and then Is_Modular_Integer_Type (Ltyp)
1129 then
1130 return Unknown;
1131
1132 -- For access types, the only time we know the result at compile time
1133 -- (apart from identical operands, which we handled already) is if we
1134 -- know one operand is null and the other is not, or both operands are
1135 -- known null.
1136
1137 elsif Is_Access_Type (Ltyp) then
1138 if Known_Null (L) then
1139 if Known_Null (R) then
1140 return EQ;
1141 elsif Known_Non_Null (R) then
1142 return NE;
1143 else
1144 return Unknown;
1145 end if;
1146
1147 elsif Known_Non_Null (L) and then Known_Null (R) then
1148 return NE;
1149
1150 else
1151 return Unknown;
1152 end if;
1153
1154 -- Case where comparison involves two compile time known values
1155
1156 elsif Compile_Time_Known_Value (L)
1157 and then
1158 Compile_Time_Known_Value (R)
1159 then
1160 -- For the floating-point case, we have to be a little careful, since
1161 -- at compile time we are dealing with universal exact values, but at
1162 -- runtime, these will be in non-exact target form. That's why the
1163 -- returned results are LE and GE below instead of LT and GT.
1164
1165 if Is_Floating_Point_Type (Ltyp)
1166 or else
1167 Is_Floating_Point_Type (Rtyp)
1168 then
1169 declare
1170 Lo : constant Ureal := Expr_Value_R (L);
1171 Hi : constant Ureal := Expr_Value_R (R);
1172 begin
1173 if Lo < Hi then
1174 return LE;
1175 elsif Lo = Hi then
1176 return EQ;
1177 else
1178 return GE;
1179 end if;
1180 end;
1181
1182 -- For string types, we have two string literals and we proceed to
1183 -- compare them using the Ada style dictionary string comparison.
1184
1185 elsif not Is_Scalar_Type (Ltyp) then
1186 declare
1187 Lstring : constant String_Id := Strval (Expr_Value_S (L));
1188 Rstring : constant String_Id := Strval (Expr_Value_S (R));
1189 Llen : constant Nat := String_Length (Lstring);
1190 Rlen : constant Nat := String_Length (Rstring);
1191
1192 begin
1193 for J in 1 .. Nat'Min (Llen, Rlen) loop
1194 declare
1195 LC : constant Char_Code := Get_String_Char (Lstring, J);
1196 RC : constant Char_Code := Get_String_Char (Rstring, J);
1197 begin
1198 if LC < RC then
1199 return LT;
1200 elsif LC > RC then
1201 return GT;
1202 end if;
1203 end;
1204 end loop;
1205
1206 if Llen < Rlen then
1207 return LT;
1208 elsif Llen > Rlen then
1209 return GT;
1210 else
1211 return EQ;
1212 end if;
1213 end;
1214
1215 -- For remaining scalar cases we know exactly (note that this does
1216 -- include the fixed-point case, where we know the run time integer
1217 -- values now).
1218
1219 else
1220 declare
1221 Lo : constant Uint := Expr_Value (L);
1222 Hi : constant Uint := Expr_Value (R);
1223 begin
1224 if Lo < Hi then
1225 Diff.all := Hi - Lo;
1226 return LT;
1227 elsif Lo = Hi then
1228 return EQ;
1229 else
1230 Diff.all := Lo - Hi;
1231 return GT;
1232 end if;
1233 end;
1234 end if;
1235
1236 -- Cases where at least one operand is not known at compile time
1237
1238 else
1239 -- Remaining checks apply only for discrete types
1240
1241 if not Is_Discrete_Type (Ltyp)
1242 or else
1243 not Is_Discrete_Type (Rtyp)
1244 then
1245 return Unknown;
1246 end if;
1247
1248 -- Defend against generic types, or actually any expressions that
1249 -- contain a reference to a generic type from within a generic
1250 -- template. We don't want to do any range analysis of such
1251 -- expressions for two reasons. First, the bounds of a generic type
1252 -- itself are junk and cannot be used for any kind of analysis.
1253 -- Second, we may have a case where the range at run time is indeed
1254 -- known, but we don't want to do compile time analysis in the
1255 -- template based on that range since in an instance the value may be
1256 -- static, and able to be elaborated without reference to the bounds
1257 -- of types involved. As an example, consider:
1258
1259 -- (F'Pos (F'Last) + 1) > Integer'Last
1260
1261 -- The expression on the left side of > is Universal_Integer and thus
1262 -- acquires the type Integer for evaluation at run time, and at run
1263 -- time it is true that this condition is always False, but within
1264 -- an instance F may be a type with a static range greater than the
1265 -- range of Integer, and the expression statically evaluates to True.
1266
1267 if References_Generic_Formal_Type (L)
1268 or else
1269 References_Generic_Formal_Type (R)
1270 then
1271 return Unknown;
1272 end if;
1273
1274 -- Replace types by base types for the case of values which are not
1275 -- known to have valid representations. This takes care of properly
1276 -- dealing with invalid representations.
1277
1278 if not Assume_Valid then
1279 if not (Is_Entity_Name (L)
1280 and then (Is_Known_Valid (Entity (L))
1281 or else Assume_No_Invalid_Values))
1282 then
1283 Ltyp := Underlying_Type (Base_Type (Ltyp));
1284 end if;
1285
1286 if not (Is_Entity_Name (R)
1287 and then (Is_Known_Valid (Entity (R))
1288 or else Assume_No_Invalid_Values))
1289 then
1290 Rtyp := Underlying_Type (Base_Type (Rtyp));
1291 end if;
1292 end if;
1293
1294 -- First attempt is to decompose the expressions to extract a
1295 -- constant offset resulting from the use of any of the forms:
1296
1297 -- expr + literal
1298 -- expr - literal
1299 -- typ'Succ (expr)
1300 -- typ'Pred (expr)
1301
1302 -- Then we see if the two expressions are the same value, and if so
1303 -- the result is obtained by comparing the offsets.
1304
1305 -- Note: the reason we do this test first is that it returns only
1306 -- decisive results (with diff set), where other tests, like the
1307 -- range test, may not be as so decisive. Consider for example
1308 -- J .. J + 1. This code can conclude LT with a difference of 1,
1309 -- even if the range of J is not known.
1310
1311 declare
1312 Lnode : Node_Id;
1313 Loffs : Uint;
1314 Rnode : Node_Id;
1315 Roffs : Uint;
1316
1317 begin
1318 Compare_Decompose (L, Lnode, Loffs);
1319 Compare_Decompose (R, Rnode, Roffs);
1320
1321 if Is_Same_Value (Lnode, Rnode) then
1322 if Loffs = Roffs then
1323 return EQ;
1324 elsif Loffs < Roffs then
1325 Diff.all := Roffs - Loffs;
1326 return LT;
1327 else
1328 Diff.all := Loffs - Roffs;
1329 return GT;
1330 end if;
1331 end if;
1332 end;
1333
1334 -- Next, try range analysis and see if operand ranges are disjoint
1335
1336 declare
1337 LOK, ROK : Boolean;
1338 LLo, LHi : Uint;
1339 RLo, RHi : Uint;
1340
1341 Single : Boolean;
1342 -- True if each range is a single point
1343
1344 begin
1345 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
1346 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
1347
1348 if LOK and ROK then
1349 Single := (LLo = LHi) and then (RLo = RHi);
1350
1351 if LHi < RLo then
1352 if Single and Assume_Valid then
1353 Diff.all := RLo - LLo;
1354 end if;
1355
1356 return LT;
1357
1358 elsif RHi < LLo then
1359 if Single and Assume_Valid then
1360 Diff.all := LLo - RLo;
1361 end if;
1362
1363 return GT;
1364
1365 elsif Single and then LLo = RLo then
1366
1367 -- If the range includes a single literal and we can assume
1368 -- validity then the result is known even if an operand is
1369 -- not static.
1370
1371 if Assume_Valid then
1372 return EQ;
1373 else
1374 return Unknown;
1375 end if;
1376
1377 elsif LHi = RLo then
1378 return LE;
1379
1380 elsif RHi = LLo then
1381 return GE;
1382
1383 elsif not Is_Known_Valid_Operand (L)
1384 and then not Assume_Valid
1385 then
1386 if Is_Same_Value (L, R) then
1387 return EQ;
1388 else
1389 return Unknown;
1390 end if;
1391 end if;
1392
1393 -- If the range of either operand cannot be determined, nothing
1394 -- further can be inferred.
1395
1396 else
1397 return Unknown;
1398 end if;
1399 end;
1400
1401 -- Here is where we check for comparisons against maximum bounds of
1402 -- types, where we know that no value can be outside the bounds of
1403 -- the subtype. Note that this routine is allowed to assume that all
1404 -- expressions are within their subtype bounds. Callers wishing to
1405 -- deal with possibly invalid values must in any case take special
1406 -- steps (e.g. conversions to larger types) to avoid this kind of
1407 -- optimization, which is always considered to be valid. We do not
1408 -- attempt this optimization with generic types, since the type
1409 -- bounds may not be meaningful in this case.
1410
1411 -- We are in danger of an infinite recursion here. It does not seem
1412 -- useful to go more than one level deep, so the parameter Rec is
1413 -- used to protect ourselves against this infinite recursion.
1414
1415 if not Rec then
1416
1417 -- See if we can get a decisive check against one operand and a
1418 -- bound of the other operand (four possible tests here). Note
1419 -- that we avoid testing junk bounds of a generic type.
1420
1421 if not Is_Generic_Type (Rtyp) then
1422 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1423 Discard'Access,
1424 Assume_Valid, Rec => True)
1425 is
1426 when LT => return LT;
1427 when LE => return LE;
1428 when EQ => return LE;
1429 when others => null;
1430 end case;
1431
1432 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1433 Discard'Access,
1434 Assume_Valid, Rec => True)
1435 is
1436 when GT => return GT;
1437 when GE => return GE;
1438 when EQ => return GE;
1439 when others => null;
1440 end case;
1441 end if;
1442
1443 if not Is_Generic_Type (Ltyp) then
1444 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1445 Discard'Access,
1446 Assume_Valid, Rec => True)
1447 is
1448 when GT => return GT;
1449 when GE => return GE;
1450 when EQ => return GE;
1451 when others => null;
1452 end case;
1453
1454 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1455 Discard'Access,
1456 Assume_Valid, Rec => True)
1457 is
1458 when LT => return LT;
1459 when LE => return LE;
1460 when EQ => return LE;
1461 when others => null;
1462 end case;
1463 end if;
1464 end if;
1465
1466 -- Next attempt is to see if we have an entity compared with a
1467 -- compile time known value, where there is a current value
1468 -- conditional for the entity which can tell us the result.
1469
1470 declare
1471 Var : Node_Id;
1472 -- Entity variable (left operand)
1473
1474 Val : Uint;
1475 -- Value (right operand)
1476
1477 Inv : Boolean;
1478 -- If False, we have reversed the operands
1479
1480 Op : Node_Kind;
1481 -- Comparison operator kind from Get_Current_Value_Condition call
1482
1483 Opn : Node_Id;
1484 -- Value from Get_Current_Value_Condition call
1485
1486 Opv : Uint;
1487 -- Value of Opn
1488
1489 Result : Compare_Result;
1490 -- Known result before inversion
1491
1492 begin
1493 if Is_Entity_Name (L)
1494 and then Compile_Time_Known_Value (R)
1495 then
1496 Var := L;
1497 Val := Expr_Value (R);
1498 Inv := False;
1499
1500 elsif Is_Entity_Name (R)
1501 and then Compile_Time_Known_Value (L)
1502 then
1503 Var := R;
1504 Val := Expr_Value (L);
1505 Inv := True;
1506
1507 -- That was the last chance at finding a compile time result
1508
1509 else
1510 return Unknown;
1511 end if;
1512
1513 Get_Current_Value_Condition (Var, Op, Opn);
1514
1515 -- That was the last chance, so if we got nothing return
1516
1517 if No (Opn) then
1518 return Unknown;
1519 end if;
1520
1521 Opv := Expr_Value (Opn);
1522
1523 -- We got a comparison, so we might have something interesting
1524
1525 -- Convert LE to LT and GE to GT, just so we have fewer cases
1526
1527 if Op = N_Op_Le then
1528 Op := N_Op_Lt;
1529 Opv := Opv + 1;
1530
1531 elsif Op = N_Op_Ge then
1532 Op := N_Op_Gt;
1533 Opv := Opv - 1;
1534 end if;
1535
1536 -- Deal with equality case
1537
1538 if Op = N_Op_Eq then
1539 if Val = Opv then
1540 Result := EQ;
1541 elsif Opv < Val then
1542 Result := LT;
1543 else
1544 Result := GT;
1545 end if;
1546
1547 -- Deal with inequality case
1548
1549 elsif Op = N_Op_Ne then
1550 if Val = Opv then
1551 Result := NE;
1552 else
1553 return Unknown;
1554 end if;
1555
1556 -- Deal with greater than case
1557
1558 elsif Op = N_Op_Gt then
1559 if Opv >= Val then
1560 Result := GT;
1561 elsif Opv = Val - 1 then
1562 Result := GE;
1563 else
1564 return Unknown;
1565 end if;
1566
1567 -- Deal with less than case
1568
1569 else pragma Assert (Op = N_Op_Lt);
1570 if Opv <= Val then
1571 Result := LT;
1572 elsif Opv = Val + 1 then
1573 Result := LE;
1574 else
1575 return Unknown;
1576 end if;
1577 end if;
1578
1579 -- Deal with inverting result
1580
1581 if Inv then
1582 case Result is
1583 when GT => return LT;
1584 when GE => return LE;
1585 when LT => return GT;
1586 when LE => return GE;
1587 when others => return Result;
1588 end case;
1589 end if;
1590
1591 return Result;
1592 end;
1593 end if;
1594 end Compile_Time_Compare;
1595
1596 -------------------------------
1597 -- Compile_Time_Known_Bounds --
1598 -------------------------------
1599
1600 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1601 Indx : Node_Id;
1602 Typ : Entity_Id;
1603
1604 begin
1605 if T = Any_Composite or else not Is_Array_Type (T) then
1606 return False;
1607 end if;
1608
1609 Indx := First_Index (T);
1610 while Present (Indx) loop
1611 Typ := Underlying_Type (Etype (Indx));
1612
1613 -- Never look at junk bounds of a generic type
1614
1615 if Is_Generic_Type (Typ) then
1616 return False;
1617 end if;
1618
1619 -- Otherwise check bounds for compile time known
1620
1621 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1622 return False;
1623 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1624 return False;
1625 else
1626 Next_Index (Indx);
1627 end if;
1628 end loop;
1629
1630 return True;
1631 end Compile_Time_Known_Bounds;
1632
1633 ------------------------------
1634 -- Compile_Time_Known_Value --
1635 ------------------------------
1636
1637 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1638 K : constant Node_Kind := Nkind (Op);
1639 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1640
1641 begin
1642 -- Never known at compile time if bad type or raises constraint error
1643 -- or empty (latter case occurs only as a result of a previous error).
1644
1645 if No (Op) then
1646 Check_Error_Detected;
1647 return False;
1648
1649 elsif Op = Error
1650 or else Etype (Op) = Any_Type
1651 or else Raises_Constraint_Error (Op)
1652 then
1653 return False;
1654 end if;
1655
1656 -- If we have an entity name, then see if it is the name of a constant
1657 -- and if so, test the corresponding constant value, or the name of
1658 -- an enumeration literal, which is always a constant.
1659
1660 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1661 declare
1662 E : constant Entity_Id := Entity (Op);
1663 V : Node_Id;
1664
1665 begin
1666 -- Never known at compile time if it is a packed array value.
1667 -- We might want to try to evaluate these at compile time one
1668 -- day, but we do not make that attempt now.
1669
1670 if Is_Packed_Array_Impl_Type (Etype (Op)) then
1671 return False;
1672 end if;
1673
1674 if Ekind (E) = E_Enumeration_Literal then
1675 return True;
1676
1677 elsif Ekind (E) = E_Constant then
1678 V := Constant_Value (E);
1679 return Present (V) and then Compile_Time_Known_Value (V);
1680 end if;
1681 end;
1682
1683 -- We have a value, see if it is compile time known
1684
1685 else
1686 -- Integer literals are worth storing in the cache
1687
1688 if K = N_Integer_Literal then
1689 CV_Ent.N := Op;
1690 CV_Ent.V := Intval (Op);
1691 return True;
1692
1693 -- Other literals and NULL are known at compile time
1694
1695 elsif
1696 Nkind_In (K, N_Character_Literal,
1697 N_Real_Literal,
1698 N_String_Literal,
1699 N_Null)
1700 then
1701 return True;
1702 end if;
1703 end if;
1704
1705 -- If we fall through, not known at compile time
1706
1707 return False;
1708
1709 -- If we get an exception while trying to do this test, then some error
1710 -- has occurred, and we simply say that the value is not known after all
1711
1712 exception
1713 when others =>
1714 return False;
1715 end Compile_Time_Known_Value;
1716
1717 --------------------------------------
1718 -- Compile_Time_Known_Value_Or_Aggr --
1719 --------------------------------------
1720
1721 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1722 begin
1723 -- If we have an entity name, then see if it is the name of a constant
1724 -- and if so, test the corresponding constant value, or the name of
1725 -- an enumeration literal, which is always a constant.
1726
1727 if Is_Entity_Name (Op) then
1728 declare
1729 E : constant Entity_Id := Entity (Op);
1730 V : Node_Id;
1731
1732 begin
1733 if Ekind (E) = E_Enumeration_Literal then
1734 return True;
1735
1736 elsif Ekind (E) /= E_Constant then
1737 return False;
1738
1739 else
1740 V := Constant_Value (E);
1741 return Present (V)
1742 and then Compile_Time_Known_Value_Or_Aggr (V);
1743 end if;
1744 end;
1745
1746 -- We have a value, see if it is compile time known
1747
1748 else
1749 if Compile_Time_Known_Value (Op) then
1750 return True;
1751
1752 elsif Nkind (Op) = N_Aggregate then
1753
1754 if Present (Expressions (Op)) then
1755 declare
1756 Expr : Node_Id;
1757 begin
1758 Expr := First (Expressions (Op));
1759 while Present (Expr) loop
1760 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1761 return False;
1762 else
1763 Next (Expr);
1764 end if;
1765 end loop;
1766 end;
1767 end if;
1768
1769 if Present (Component_Associations (Op)) then
1770 declare
1771 Cass : Node_Id;
1772
1773 begin
1774 Cass := First (Component_Associations (Op));
1775 while Present (Cass) loop
1776 if not
1777 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1778 then
1779 return False;
1780 end if;
1781
1782 Next (Cass);
1783 end loop;
1784 end;
1785 end if;
1786
1787 return True;
1788
1789 -- All other types of values are not known at compile time
1790
1791 else
1792 return False;
1793 end if;
1794
1795 end if;
1796 end Compile_Time_Known_Value_Or_Aggr;
1797
1798 ---------------------------------------
1799 -- CRT_Safe_Compile_Time_Known_Value --
1800 ---------------------------------------
1801
1802 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1803 begin
1804 if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
1805 and then not Is_OK_Static_Expression (Op)
1806 then
1807 return False;
1808 else
1809 return Compile_Time_Known_Value (Op);
1810 end if;
1811 end CRT_Safe_Compile_Time_Known_Value;
1812
1813 -----------------
1814 -- Eval_Actual --
1815 -----------------
1816
1817 -- This is only called for actuals of functions that are not predefined
1818 -- operators (which have already been rewritten as operators at this
1819 -- stage), so the call can never be folded, and all that needs doing for
1820 -- the actual is to do the check for a non-static context.
1821
1822 procedure Eval_Actual (N : Node_Id) is
1823 begin
1824 Check_Non_Static_Context (N);
1825 end Eval_Actual;
1826
1827 --------------------
1828 -- Eval_Allocator --
1829 --------------------
1830
1831 -- Allocators are never static, so all we have to do is to do the
1832 -- check for a non-static context if an expression is present.
1833
1834 procedure Eval_Allocator (N : Node_Id) is
1835 Expr : constant Node_Id := Expression (N);
1836 begin
1837 if Nkind (Expr) = N_Qualified_Expression then
1838 Check_Non_Static_Context (Expression (Expr));
1839 end if;
1840 end Eval_Allocator;
1841
1842 ------------------------
1843 -- Eval_Arithmetic_Op --
1844 ------------------------
1845
1846 -- Arithmetic operations are static functions, so the result is static
1847 -- if both operands are static (RM 4.9(7), 4.9(20)).
1848
1849 procedure Eval_Arithmetic_Op (N : Node_Id) is
1850 Left : constant Node_Id := Left_Opnd (N);
1851 Right : constant Node_Id := Right_Opnd (N);
1852 Ltype : constant Entity_Id := Etype (Left);
1853 Rtype : constant Entity_Id := Etype (Right);
1854 Otype : Entity_Id := Empty;
1855 Stat : Boolean;
1856 Fold : Boolean;
1857
1858 begin
1859 -- If not foldable we are done
1860
1861 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1862
1863 if not Fold then
1864 return;
1865 end if;
1866
1867 -- Otherwise attempt to fold
1868
1869 if Is_Universal_Numeric_Type (Etype (Left))
1870 and then
1871 Is_Universal_Numeric_Type (Etype (Right))
1872 then
1873 Otype := Find_Universal_Operator_Type (N);
1874 end if;
1875
1876 -- Fold for cases where both operands are of integer type
1877
1878 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1879 declare
1880 Left_Int : constant Uint := Expr_Value (Left);
1881 Right_Int : constant Uint := Expr_Value (Right);
1882 Result : Uint;
1883
1884 begin
1885 case Nkind (N) is
1886 when N_Op_Add =>
1887 Result := Left_Int + Right_Int;
1888
1889 when N_Op_Subtract =>
1890 Result := Left_Int - Right_Int;
1891
1892 when N_Op_Multiply =>
1893 if OK_Bits
1894 (N, UI_From_Int
1895 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1896 then
1897 Result := Left_Int * Right_Int;
1898 else
1899 Result := Left_Int;
1900 end if;
1901
1902 when N_Op_Divide =>
1903
1904 -- The exception Constraint_Error is raised by integer
1905 -- division, rem and mod if the right operand is zero.
1906
1907 if Right_Int = 0 then
1908
1909 -- When SPARK_Mode is On, force a warning instead of
1910 -- an error in that case, as this likely corresponds
1911 -- to deactivated code.
1912
1913 Apply_Compile_Time_Constraint_Error
1914 (N, "division by zero", CE_Divide_By_Zero,
1915 Warn => not Stat or SPARK_Mode = On);
1916 Set_Raises_Constraint_Error (N);
1917 return;
1918
1919 -- Otherwise we can do the division
1920
1921 else
1922 Result := Left_Int / Right_Int;
1923 end if;
1924
1925 when N_Op_Mod =>
1926
1927 -- The exception Constraint_Error is raised by integer
1928 -- division, rem and mod if the right operand is zero.
1929
1930 if Right_Int = 0 then
1931
1932 -- When SPARK_Mode is On, force a warning instead of
1933 -- an error in that case, as this likely corresponds
1934 -- to deactivated code.
1935
1936 Apply_Compile_Time_Constraint_Error
1937 (N, "mod with zero divisor", CE_Divide_By_Zero,
1938 Warn => not Stat or SPARK_Mode = On);
1939 return;
1940
1941 else
1942 Result := Left_Int mod Right_Int;
1943 end if;
1944
1945 when N_Op_Rem =>
1946
1947 -- The exception Constraint_Error is raised by integer
1948 -- division, rem and mod if the right operand is zero.
1949
1950 if Right_Int = 0 then
1951
1952 -- When SPARK_Mode is On, force a warning instead of
1953 -- an error in that case, as this likely corresponds
1954 -- to deactivated code.
1955
1956 Apply_Compile_Time_Constraint_Error
1957 (N, "rem with zero divisor", CE_Divide_By_Zero,
1958 Warn => not Stat or SPARK_Mode = On);
1959 return;
1960
1961 else
1962 Result := Left_Int rem Right_Int;
1963 end if;
1964
1965 when others =>
1966 raise Program_Error;
1967 end case;
1968
1969 -- Adjust the result by the modulus if the type is a modular type
1970
1971 if Is_Modular_Integer_Type (Ltype) then
1972 Result := Result mod Modulus (Ltype);
1973
1974 -- For a signed integer type, check non-static overflow
1975
1976 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1977 declare
1978 BT : constant Entity_Id := Base_Type (Ltype);
1979 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1980 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1981 begin
1982 if Result < Lo or else Result > Hi then
1983 Apply_Compile_Time_Constraint_Error
1984 (N, "value not in range of }??",
1985 CE_Overflow_Check_Failed,
1986 Ent => BT);
1987 return;
1988 end if;
1989 end;
1990 end if;
1991
1992 -- If we get here we can fold the result
1993
1994 Fold_Uint (N, Result, Stat);
1995 end;
1996
1997 -- Cases where at least one operand is a real. We handle the cases of
1998 -- both reals, or mixed/real integer cases (the latter happen only for
1999 -- divide and multiply, and the result is always real).
2000
2001 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
2002 declare
2003 Left_Real : Ureal;
2004 Right_Real : Ureal;
2005 Result : Ureal;
2006
2007 begin
2008 if Is_Real_Type (Ltype) then
2009 Left_Real := Expr_Value_R (Left);
2010 else
2011 Left_Real := UR_From_Uint (Expr_Value (Left));
2012 end if;
2013
2014 if Is_Real_Type (Rtype) then
2015 Right_Real := Expr_Value_R (Right);
2016 else
2017 Right_Real := UR_From_Uint (Expr_Value (Right));
2018 end if;
2019
2020 if Nkind (N) = N_Op_Add then
2021 Result := Left_Real + Right_Real;
2022
2023 elsif Nkind (N) = N_Op_Subtract then
2024 Result := Left_Real - Right_Real;
2025
2026 elsif Nkind (N) = N_Op_Multiply then
2027 Result := Left_Real * Right_Real;
2028
2029 else pragma Assert (Nkind (N) = N_Op_Divide);
2030 if UR_Is_Zero (Right_Real) then
2031 Apply_Compile_Time_Constraint_Error
2032 (N, "division by zero", CE_Divide_By_Zero);
2033 return;
2034 end if;
2035
2036 Result := Left_Real / Right_Real;
2037 end if;
2038
2039 Fold_Ureal (N, Result, Stat);
2040 end;
2041 end if;
2042
2043 -- If the operator was resolved to a specific type, make sure that type
2044 -- is frozen even if the expression is folded into a literal (which has
2045 -- a universal type).
2046
2047 if Present (Otype) then
2048 Freeze_Before (N, Otype);
2049 end if;
2050 end Eval_Arithmetic_Op;
2051
2052 ----------------------------
2053 -- Eval_Character_Literal --
2054 ----------------------------
2055
2056 -- Nothing to be done
2057
2058 procedure Eval_Character_Literal (N : Node_Id) is
2059 pragma Warnings (Off, N);
2060 begin
2061 null;
2062 end Eval_Character_Literal;
2063
2064 ---------------
2065 -- Eval_Call --
2066 ---------------
2067
2068 -- Static function calls are either calls to predefined operators
2069 -- with static arguments, or calls to functions that rename a literal.
2070 -- Only the latter case is handled here, predefined operators are
2071 -- constant-folded elsewhere.
2072
2073 -- If the function is itself inherited (see 7423-001) the literal of
2074 -- the parent type must be explicitly converted to the return type
2075 -- of the function.
2076
2077 procedure Eval_Call (N : Node_Id) is
2078 Loc : constant Source_Ptr := Sloc (N);
2079 Typ : constant Entity_Id := Etype (N);
2080 Lit : Entity_Id;
2081
2082 begin
2083 if Nkind (N) = N_Function_Call
2084 and then No (Parameter_Associations (N))
2085 and then Is_Entity_Name (Name (N))
2086 and then Present (Alias (Entity (Name (N))))
2087 and then Is_Enumeration_Type (Base_Type (Typ))
2088 then
2089 Lit := Ultimate_Alias (Entity (Name (N)));
2090
2091 if Ekind (Lit) = E_Enumeration_Literal then
2092 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
2093 Rewrite
2094 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
2095 else
2096 Rewrite (N, New_Occurrence_Of (Lit, Loc));
2097 end if;
2098
2099 Resolve (N, Typ);
2100 end if;
2101 end if;
2102 end Eval_Call;
2103
2104 --------------------------
2105 -- Eval_Case_Expression --
2106 --------------------------
2107
2108 -- A conditional expression is static if all its conditions and dependent
2109 -- expressions are static. Note that we do not care if the dependent
2110 -- expressions raise CE, except for the one that will be selected.
2111
2112 procedure Eval_Case_Expression (N : Node_Id) is
2113 Alt : Node_Id;
2114 Choice : Node_Id;
2115
2116 begin
2117 Set_Is_Static_Expression (N, False);
2118
2119 if not Is_Static_Expression (Expression (N)) then
2120 Check_Non_Static_Context (Expression (N));
2121 return;
2122 end if;
2123
2124 -- First loop, make sure all the alternatives are static expressions
2125 -- none of which raise Constraint_Error. We make the constraint error
2126 -- check because part of the legality condition for a correct static
2127 -- case expression is that the cases are covered, like any other case
2128 -- expression. And we can't do that if any of the conditions raise an
2129 -- exception, so we don't even try to evaluate if that is the case.
2130
2131 Alt := First (Alternatives (N));
2132 while Present (Alt) loop
2133
2134 -- The expression must be static, but we don't care at this stage
2135 -- if it raises Constraint_Error (the alternative might not match,
2136 -- in which case the expression is statically unevaluated anyway).
2137
2138 if not Is_Static_Expression (Expression (Alt)) then
2139 Check_Non_Static_Context (Expression (Alt));
2140 return;
2141 end if;
2142
2143 -- The choices of a case always have to be static, and cannot raise
2144 -- an exception. If this condition is not met, then the expression
2145 -- is plain illegal, so just abandon evaluation attempts. No need
2146 -- to check non-static context when we have something illegal anyway.
2147
2148 if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
2149 return;
2150 end if;
2151
2152 Next (Alt);
2153 end loop;
2154
2155 -- OK, if the above loop gets through it means that all choices are OK
2156 -- static (don't raise exceptions), so the whole case is static, and we
2157 -- can find the matching alternative.
2158
2159 Set_Is_Static_Expression (N);
2160
2161 -- Now to deal with propagating a possible constraint error
2162
2163 -- If the selecting expression raises CE, propagate and we are done
2164
2165 if Raises_Constraint_Error (Expression (N)) then
2166 Set_Raises_Constraint_Error (N);
2167
2168 -- Otherwise we need to check the alternatives to find the matching
2169 -- one. CE's in other than the matching one are not relevant. But we
2170 -- do need to check the matching one. Unlike the first loop, we do not
2171 -- have to go all the way through, when we find the matching one, quit.
2172
2173 else
2174 Alt := First (Alternatives (N));
2175 Search : loop
2176
2177 -- We must find a match among the alternatives. If not, this must
2178 -- be due to other errors, so just ignore, leaving as non-static.
2179
2180 if No (Alt) then
2181 Set_Is_Static_Expression (N, False);
2182 return;
2183 end if;
2184
2185 -- Otherwise loop through choices of this alternative
2186
2187 Choice := First (Discrete_Choices (Alt));
2188 while Present (Choice) loop
2189
2190 -- If we find a matching choice, then the Expression of this
2191 -- alternative replaces N (Raises_Constraint_Error flag is
2192 -- included, so we don't have to special case that).
2193
2194 if Choice_Matches (Expression (N), Choice) = Match then
2195 Rewrite (N, Relocate_Node (Expression (Alt)));
2196 return;
2197 end if;
2198
2199 Next (Choice);
2200 end loop;
2201
2202 Next (Alt);
2203 end loop Search;
2204 end if;
2205 end Eval_Case_Expression;
2206
2207 ------------------------
2208 -- Eval_Concatenation --
2209 ------------------------
2210
2211 -- Concatenation is a static function, so the result is static if both
2212 -- operands are static (RM 4.9(7), 4.9(21)).
2213
2214 procedure Eval_Concatenation (N : Node_Id) is
2215 Left : constant Node_Id := Left_Opnd (N);
2216 Right : constant Node_Id := Right_Opnd (N);
2217 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
2218 Stat : Boolean;
2219 Fold : Boolean;
2220
2221 begin
2222 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2223 -- non-static context.
2224
2225 if Ada_Version = Ada_83
2226 and then Comes_From_Source (N)
2227 then
2228 Check_Non_Static_Context (Left);
2229 Check_Non_Static_Context (Right);
2230 return;
2231 end if;
2232
2233 -- If not foldable we are done. In principle concatenation that yields
2234 -- any string type is static (i.e. an array type of character types).
2235 -- However, character types can include enumeration literals, and
2236 -- concatenation in that case cannot be described by a literal, so we
2237 -- only consider the operation static if the result is an array of
2238 -- (a descendant of) a predefined character type.
2239
2240 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2241
2242 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
2243 Set_Is_Static_Expression (N, False);
2244 return;
2245 end if;
2246
2247 -- Compile time string concatenation
2248
2249 -- ??? Note that operands that are aggregates can be marked as static,
2250 -- so we should attempt at a later stage to fold concatenations with
2251 -- such aggregates.
2252
2253 declare
2254 Left_Str : constant Node_Id := Get_String_Val (Left);
2255 Left_Len : Nat;
2256 Right_Str : constant Node_Id := Get_String_Val (Right);
2257 Folded_Val : String_Id;
2258
2259 begin
2260 -- Establish new string literal, and store left operand. We make
2261 -- sure to use the special Start_String that takes an operand if
2262 -- the left operand is a string literal. Since this is optimized
2263 -- in the case where that is the most recently created string
2264 -- literal, we ensure efficient time/space behavior for the
2265 -- case of a concatenation of a series of string literals.
2266
2267 if Nkind (Left_Str) = N_String_Literal then
2268 Left_Len := String_Length (Strval (Left_Str));
2269
2270 -- If the left operand is the empty string, and the right operand
2271 -- is a string literal (the case of "" & "..."), the result is the
2272 -- value of the right operand. This optimization is important when
2273 -- Is_Folded_In_Parser, to avoid copying an enormous right
2274 -- operand.
2275
2276 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
2277 Folded_Val := Strval (Right_Str);
2278 else
2279 Start_String (Strval (Left_Str));
2280 end if;
2281
2282 else
2283 Start_String;
2284 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
2285 Left_Len := 1;
2286 end if;
2287
2288 -- Now append the characters of the right operand, unless we
2289 -- optimized the "" & "..." case above.
2290
2291 if Nkind (Right_Str) = N_String_Literal then
2292 if Left_Len /= 0 then
2293 Store_String_Chars (Strval (Right_Str));
2294 Folded_Val := End_String;
2295 end if;
2296 else
2297 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
2298 Folded_Val := End_String;
2299 end if;
2300
2301 Set_Is_Static_Expression (N, Stat);
2302
2303 -- If left operand is the empty string, the result is the
2304 -- right operand, including its bounds if anomalous.
2305
2306 if Left_Len = 0
2307 and then Is_Array_Type (Etype (Right))
2308 and then Etype (Right) /= Any_String
2309 then
2310 Set_Etype (N, Etype (Right));
2311 end if;
2312
2313 Fold_Str (N, Folded_Val, Static => Stat);
2314 end;
2315 end Eval_Concatenation;
2316
2317 ----------------------
2318 -- Eval_Entity_Name --
2319 ----------------------
2320
2321 -- This procedure is used for identifiers and expanded names other than
2322 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2323 -- static if they denote a static constant (RM 4.9(6)) or if the name
2324 -- denotes an enumeration literal (RM 4.9(22)).
2325
2326 procedure Eval_Entity_Name (N : Node_Id) is
2327 Def_Id : constant Entity_Id := Entity (N);
2328 Val : Node_Id;
2329
2330 begin
2331 -- Enumeration literals are always considered to be constants
2332 -- and cannot raise constraint error (RM 4.9(22)).
2333
2334 if Ekind (Def_Id) = E_Enumeration_Literal then
2335 Set_Is_Static_Expression (N);
2336 return;
2337
2338 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2339 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2340 -- it does not violate 10.2.1(8) here, since this is not a variable.
2341
2342 elsif Ekind (Def_Id) = E_Constant then
2343
2344 -- Deferred constants must always be treated as nonstatic outside the
2345 -- scope of their full view.
2346
2347 if Present (Full_View (Def_Id))
2348 and then not In_Open_Scopes (Scope (Def_Id))
2349 then
2350 Val := Empty;
2351 else
2352 Val := Constant_Value (Def_Id);
2353 end if;
2354
2355 if Present (Val) then
2356 Set_Is_Static_Expression
2357 (N, Is_Static_Expression (Val)
2358 and then Is_Static_Subtype (Etype (Def_Id)));
2359 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
2360
2361 if not Is_Static_Expression (N)
2362 and then not Is_Generic_Type (Etype (N))
2363 then
2364 Validate_Static_Object_Name (N);
2365 end if;
2366
2367 -- Mark constant condition in SCOs
2368
2369 if Generate_SCO
2370 and then Comes_From_Source (N)
2371 and then Is_Boolean_Type (Etype (Def_Id))
2372 and then Compile_Time_Known_Value (N)
2373 then
2374 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
2375 end if;
2376
2377 return;
2378 end if;
2379 end if;
2380
2381 -- Fall through if the name is not static
2382
2383 Validate_Static_Object_Name (N);
2384 end Eval_Entity_Name;
2385
2386 ------------------------
2387 -- Eval_If_Expression --
2388 ------------------------
2389
2390 -- We can fold to a static expression if the condition and both dependent
2391 -- expressions are static. Otherwise, the only required processing is to do
2392 -- the check for non-static context for the then and else expressions.
2393
2394 procedure Eval_If_Expression (N : Node_Id) is
2395 Condition : constant Node_Id := First (Expressions (N));
2396 Then_Expr : constant Node_Id := Next (Condition);
2397 Else_Expr : constant Node_Id := Next (Then_Expr);
2398 Result : Node_Id;
2399 Non_Result : Node_Id;
2400
2401 Rstat : constant Boolean :=
2402 Is_Static_Expression (Condition)
2403 and then
2404 Is_Static_Expression (Then_Expr)
2405 and then
2406 Is_Static_Expression (Else_Expr);
2407 -- True if result is static
2408
2409 begin
2410 -- If result not static, nothing to do, otherwise set static result
2411
2412 if not Rstat then
2413 return;
2414 else
2415 Set_Is_Static_Expression (N);
2416 end if;
2417
2418 -- If any operand is Any_Type, just propagate to result and do not try
2419 -- to fold, this prevents cascaded errors.
2420
2421 if Etype (Condition) = Any_Type or else
2422 Etype (Then_Expr) = Any_Type or else
2423 Etype (Else_Expr) = Any_Type
2424 then
2425 Set_Etype (N, Any_Type);
2426 Set_Is_Static_Expression (N, False);
2427 return;
2428 end if;
2429
2430 -- If condition raises constraint error then we have already signaled
2431 -- an error, and we just propagate to the result and do not fold.
2432
2433 if Raises_Constraint_Error (Condition) then
2434 Set_Raises_Constraint_Error (N);
2435 return;
2436 end if;
2437
2438 -- Static case where we can fold. Note that we don't try to fold cases
2439 -- where the condition is known at compile time, but the result is
2440 -- non-static. This avoids possible cases of infinite recursion where
2441 -- the expander puts in a redundant test and we remove it. Instead we
2442 -- deal with these cases in the expander.
2443
2444 -- Select result operand
2445
2446 if Is_True (Expr_Value (Condition)) then
2447 Result := Then_Expr;
2448 Non_Result := Else_Expr;
2449 else
2450 Result := Else_Expr;
2451 Non_Result := Then_Expr;
2452 end if;
2453
2454 -- Note that it does not matter if the non-result operand raises a
2455 -- Constraint_Error, but if the result raises constraint error then we
2456 -- replace the node with a raise constraint error. This will properly
2457 -- propagate Raises_Constraint_Error since this flag is set in Result.
2458
2459 if Raises_Constraint_Error (Result) then
2460 Rewrite_In_Raise_CE (N, Result);
2461 Check_Non_Static_Context (Non_Result);
2462
2463 -- Otherwise the result operand replaces the original node
2464
2465 else
2466 Rewrite (N, Relocate_Node (Result));
2467 Set_Is_Static_Expression (N);
2468 end if;
2469 end Eval_If_Expression;
2470
2471 ----------------------------
2472 -- Eval_Indexed_Component --
2473 ----------------------------
2474
2475 -- Indexed components are never static, so we need to perform the check
2476 -- for non-static context on the index values. Then, we check if the
2477 -- value can be obtained at compile time, even though it is non-static.
2478
2479 procedure Eval_Indexed_Component (N : Node_Id) is
2480 Expr : Node_Id;
2481
2482 begin
2483 -- Check for non-static context on index values
2484
2485 Expr := First (Expressions (N));
2486 while Present (Expr) loop
2487 Check_Non_Static_Context (Expr);
2488 Next (Expr);
2489 end loop;
2490
2491 -- If the indexed component appears in an object renaming declaration
2492 -- then we do not want to try to evaluate it, since in this case we
2493 -- need the identity of the array element.
2494
2495 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2496 return;
2497
2498 -- Similarly if the indexed component appears as the prefix of an
2499 -- attribute we don't want to evaluate it, because at least for
2500 -- some cases of attributes we need the identify (e.g. Access, Size)
2501
2502 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2503 return;
2504 end if;
2505
2506 -- Note: there are other cases, such as the left side of an assignment,
2507 -- or an OUT parameter for a call, where the replacement results in the
2508 -- illegal use of a constant, But these cases are illegal in the first
2509 -- place, so the replacement, though silly, is harmless.
2510
2511 -- Now see if this is a constant array reference
2512
2513 if List_Length (Expressions (N)) = 1
2514 and then Is_Entity_Name (Prefix (N))
2515 and then Ekind (Entity (Prefix (N))) = E_Constant
2516 and then Present (Constant_Value (Entity (Prefix (N))))
2517 then
2518 declare
2519 Loc : constant Source_Ptr := Sloc (N);
2520 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2521 Sub : constant Node_Id := First (Expressions (N));
2522
2523 Atyp : Entity_Id;
2524 -- Type of array
2525
2526 Lin : Nat;
2527 -- Linear one's origin subscript value for array reference
2528
2529 Lbd : Node_Id;
2530 -- Lower bound of the first array index
2531
2532 Elm : Node_Id;
2533 -- Value from constant array
2534
2535 begin
2536 Atyp := Etype (Arr);
2537
2538 if Is_Access_Type (Atyp) then
2539 Atyp := Designated_Type (Atyp);
2540 end if;
2541
2542 -- If we have an array type (we should have but perhaps there are
2543 -- error cases where this is not the case), then see if we can do
2544 -- a constant evaluation of the array reference.
2545
2546 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2547 if Ekind (Atyp) = E_String_Literal_Subtype then
2548 Lbd := String_Literal_Low_Bound (Atyp);
2549 else
2550 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2551 end if;
2552
2553 if Compile_Time_Known_Value (Sub)
2554 and then Nkind (Arr) = N_Aggregate
2555 and then Compile_Time_Known_Value (Lbd)
2556 and then Is_Discrete_Type (Component_Type (Atyp))
2557 then
2558 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2559
2560 if List_Length (Expressions (Arr)) >= Lin then
2561 Elm := Pick (Expressions (Arr), Lin);
2562
2563 -- If the resulting expression is compile time known,
2564 -- then we can rewrite the indexed component with this
2565 -- value, being sure to mark the result as non-static.
2566 -- We also reset the Sloc, in case this generates an
2567 -- error later on (e.g. 136'Access).
2568
2569 if Compile_Time_Known_Value (Elm) then
2570 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2571 Set_Is_Static_Expression (N, False);
2572 Set_Sloc (N, Loc);
2573 end if;
2574 end if;
2575
2576 -- We can also constant-fold if the prefix is a string literal.
2577 -- This will be useful in an instantiation or an inlining.
2578
2579 elsif Compile_Time_Known_Value (Sub)
2580 and then Nkind (Arr) = N_String_Literal
2581 and then Compile_Time_Known_Value (Lbd)
2582 and then Expr_Value (Lbd) = 1
2583 and then Expr_Value (Sub) <=
2584 String_Literal_Length (Etype (Arr))
2585 then
2586 declare
2587 C : constant Char_Code :=
2588 Get_String_Char (Strval (Arr),
2589 UI_To_Int (Expr_Value (Sub)));
2590 begin
2591 Set_Character_Literal_Name (C);
2592
2593 Elm :=
2594 Make_Character_Literal (Loc,
2595 Chars => Name_Find,
2596 Char_Literal_Value => UI_From_CC (C));
2597 Set_Etype (Elm, Component_Type (Atyp));
2598 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2599 Set_Is_Static_Expression (N, False);
2600 end;
2601 end if;
2602 end if;
2603 end;
2604 end if;
2605 end Eval_Indexed_Component;
2606
2607 --------------------------
2608 -- Eval_Integer_Literal --
2609 --------------------------
2610
2611 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2612 -- as static by the analyzer. The reason we did it that early is to allow
2613 -- the possibility of turning off the Is_Static_Expression flag after
2614 -- analysis, but before resolution, when integer literals are generated in
2615 -- the expander that do not correspond to static expressions.
2616
2617 procedure Eval_Integer_Literal (N : Node_Id) is
2618 T : constant Entity_Id := Etype (N);
2619
2620 function In_Any_Integer_Context return Boolean;
2621 -- If the literal is resolved with a specific type in a context where
2622 -- the expected type is Any_Integer, there are no range checks on the
2623 -- literal. By the time the literal is evaluated, it carries the type
2624 -- imposed by the enclosing expression, and we must recover the context
2625 -- to determine that Any_Integer is meant.
2626
2627 ----------------------------
2628 -- In_Any_Integer_Context --
2629 ----------------------------
2630
2631 function In_Any_Integer_Context return Boolean is
2632 Par : constant Node_Id := Parent (N);
2633 K : constant Node_Kind := Nkind (Par);
2634
2635 begin
2636 -- Any_Integer also appears in digits specifications for real types,
2637 -- but those have bounds smaller that those of any integer base type,
2638 -- so we can safely ignore these cases.
2639
2640 return Nkind_In (K, N_Number_Declaration,
2641 N_Attribute_Reference,
2642 N_Attribute_Definition_Clause,
2643 N_Modular_Type_Definition,
2644 N_Signed_Integer_Type_Definition);
2645 end In_Any_Integer_Context;
2646
2647 -- Start of processing for Eval_Integer_Literal
2648
2649 begin
2650
2651 -- If the literal appears in a non-expression context, then it is
2652 -- certainly appearing in a non-static context, so check it. This is
2653 -- actually a redundant check, since Check_Non_Static_Context would
2654 -- check it, but it seems worth while avoiding the call.
2655
2656 if Nkind (Parent (N)) not in N_Subexpr
2657 and then not In_Any_Integer_Context
2658 then
2659 Check_Non_Static_Context (N);
2660 end if;
2661
2662 -- Modular integer literals must be in their base range
2663
2664 if Is_Modular_Integer_Type (T)
2665 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2666 then
2667 Out_Of_Range (N);
2668 end if;
2669 end Eval_Integer_Literal;
2670
2671 ---------------------
2672 -- Eval_Logical_Op --
2673 ---------------------
2674
2675 -- Logical operations are static functions, so the result is potentially
2676 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2677
2678 procedure Eval_Logical_Op (N : Node_Id) is
2679 Left : constant Node_Id := Left_Opnd (N);
2680 Right : constant Node_Id := Right_Opnd (N);
2681 Stat : Boolean;
2682 Fold : Boolean;
2683
2684 begin
2685 -- If not foldable we are done
2686
2687 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2688
2689 if not Fold then
2690 return;
2691 end if;
2692
2693 -- Compile time evaluation of logical operation
2694
2695 declare
2696 Left_Int : constant Uint := Expr_Value (Left);
2697 Right_Int : constant Uint := Expr_Value (Right);
2698
2699 begin
2700 if Is_Modular_Integer_Type (Etype (N)) then
2701 declare
2702 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2703 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2704
2705 begin
2706 To_Bits (Left_Int, Left_Bits);
2707 To_Bits (Right_Int, Right_Bits);
2708
2709 -- Note: should really be able to use array ops instead of
2710 -- these loops, but they weren't working at the time ???
2711
2712 if Nkind (N) = N_Op_And then
2713 for J in Left_Bits'Range loop
2714 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2715 end loop;
2716
2717 elsif Nkind (N) = N_Op_Or then
2718 for J in Left_Bits'Range loop
2719 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2720 end loop;
2721
2722 else
2723 pragma Assert (Nkind (N) = N_Op_Xor);
2724
2725 for J in Left_Bits'Range loop
2726 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2727 end loop;
2728 end if;
2729
2730 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2731 end;
2732
2733 else
2734 pragma Assert (Is_Boolean_Type (Etype (N)));
2735
2736 if Nkind (N) = N_Op_And then
2737 Fold_Uint (N,
2738 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2739
2740 elsif Nkind (N) = N_Op_Or then
2741 Fold_Uint (N,
2742 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2743
2744 else
2745 pragma Assert (Nkind (N) = N_Op_Xor);
2746 Fold_Uint (N,
2747 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2748 end if;
2749 end if;
2750 end;
2751 end Eval_Logical_Op;
2752
2753 ------------------------
2754 -- Eval_Membership_Op --
2755 ------------------------
2756
2757 -- A membership test is potentially static if the expression is static, and
2758 -- the range is a potentially static range, or is a subtype mark denoting a
2759 -- static subtype (RM 4.9(12)).
2760
2761 procedure Eval_Membership_Op (N : Node_Id) is
2762 Alts : constant List_Id := Alternatives (N);
2763 Choice : constant Node_Id := Right_Opnd (N);
2764 Expr : constant Node_Id := Left_Opnd (N);
2765 Result : Match_Result;
2766
2767 begin
2768 -- Ignore if error in either operand, except to make sure that Any_Type
2769 -- is properly propagated to avoid junk cascaded errors.
2770
2771 if Etype (Expr) = Any_Type
2772 or else (Present (Choice) and then Etype (Choice) = Any_Type)
2773 then
2774 Set_Etype (N, Any_Type);
2775 return;
2776 end if;
2777
2778 -- If left operand non-static, then nothing to do
2779
2780 if not Is_Static_Expression (Expr) then
2781 return;
2782 end if;
2783
2784 -- If choice is non-static, left operand is in non-static context
2785
2786 if (Present (Choice) and then not Is_Static_Choice (Choice))
2787 or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
2788 then
2789 Check_Non_Static_Context (Expr);
2790 return;
2791 end if;
2792
2793 -- Otherwise we definitely have a static expression
2794
2795 Set_Is_Static_Expression (N);
2796
2797 -- If left operand raises constraint error, propagate and we are done
2798
2799 if Raises_Constraint_Error (Expr) then
2800 Set_Raises_Constraint_Error (N, True);
2801
2802 -- See if we match
2803
2804 else
2805 if Present (Choice) then
2806 Result := Choice_Matches (Expr, Choice);
2807 else
2808 Result := Choices_Match (Expr, Alts);
2809 end if;
2810
2811 -- If result is Non_Static, it means that we raise Constraint_Error,
2812 -- since we already tested that the operands were themselves static.
2813
2814 if Result = Non_Static then
2815 Set_Raises_Constraint_Error (N);
2816
2817 -- Otherwise we have our result (flipped if NOT IN case)
2818
2819 else
2820 Fold_Uint
2821 (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
2822 Warn_On_Known_Condition (N);
2823 end if;
2824 end if;
2825 end Eval_Membership_Op;
2826
2827 ------------------------
2828 -- Eval_Named_Integer --
2829 ------------------------
2830
2831 procedure Eval_Named_Integer (N : Node_Id) is
2832 begin
2833 Fold_Uint (N,
2834 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2835 end Eval_Named_Integer;
2836
2837 ---------------------
2838 -- Eval_Named_Real --
2839 ---------------------
2840
2841 procedure Eval_Named_Real (N : Node_Id) is
2842 begin
2843 Fold_Ureal (N,
2844 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2845 end Eval_Named_Real;
2846
2847 -------------------
2848 -- Eval_Op_Expon --
2849 -------------------
2850
2851 -- Exponentiation is a static functions, so the result is potentially
2852 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2853
2854 procedure Eval_Op_Expon (N : Node_Id) is
2855 Left : constant Node_Id := Left_Opnd (N);
2856 Right : constant Node_Id := Right_Opnd (N);
2857 Stat : Boolean;
2858 Fold : Boolean;
2859
2860 begin
2861 -- If not foldable we are done
2862
2863 Test_Expression_Is_Foldable
2864 (N, Left, Right, Stat, Fold, CRT_Safe => True);
2865
2866 -- Return if not foldable
2867
2868 if not Fold then
2869 return;
2870 end if;
2871
2872 if Configurable_Run_Time_Mode and not Stat then
2873 return;
2874 end if;
2875
2876 -- Fold exponentiation operation
2877
2878 declare
2879 Right_Int : constant Uint := Expr_Value (Right);
2880
2881 begin
2882 -- Integer case
2883
2884 if Is_Integer_Type (Etype (Left)) then
2885 declare
2886 Left_Int : constant Uint := Expr_Value (Left);
2887 Result : Uint;
2888
2889 begin
2890 -- Exponentiation of an integer raises Constraint_Error for a
2891 -- negative exponent (RM 4.5.6).
2892
2893 if Right_Int < 0 then
2894 Apply_Compile_Time_Constraint_Error
2895 (N, "integer exponent negative", CE_Range_Check_Failed,
2896 Warn => not Stat);
2897 return;
2898
2899 else
2900 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2901 Result := Left_Int ** Right_Int;
2902 else
2903 Result := Left_Int;
2904 end if;
2905
2906 if Is_Modular_Integer_Type (Etype (N)) then
2907 Result := Result mod Modulus (Etype (N));
2908 end if;
2909
2910 Fold_Uint (N, Result, Stat);
2911 end if;
2912 end;
2913
2914 -- Real case
2915
2916 else
2917 declare
2918 Left_Real : constant Ureal := Expr_Value_R (Left);
2919
2920 begin
2921 -- Cannot have a zero base with a negative exponent
2922
2923 if UR_Is_Zero (Left_Real) then
2924
2925 if Right_Int < 0 then
2926 Apply_Compile_Time_Constraint_Error
2927 (N, "zero ** negative integer", CE_Range_Check_Failed,
2928 Warn => not Stat);
2929 return;
2930 else
2931 Fold_Ureal (N, Ureal_0, Stat);
2932 end if;
2933
2934 else
2935 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2936 end if;
2937 end;
2938 end if;
2939 end;
2940 end Eval_Op_Expon;
2941
2942 -----------------
2943 -- Eval_Op_Not --
2944 -----------------
2945
2946 -- The not operation is a static functions, so the result is potentially
2947 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2948
2949 procedure Eval_Op_Not (N : Node_Id) is
2950 Right : constant Node_Id := Right_Opnd (N);
2951 Stat : Boolean;
2952 Fold : Boolean;
2953
2954 begin
2955 -- If not foldable we are done
2956
2957 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2958
2959 if not Fold then
2960 return;
2961 end if;
2962
2963 -- Fold not operation
2964
2965 declare
2966 Rint : constant Uint := Expr_Value (Right);
2967 Typ : constant Entity_Id := Etype (N);
2968
2969 begin
2970 -- Negation is equivalent to subtracting from the modulus minus one.
2971 -- For a binary modulus this is equivalent to the ones-complement of
2972 -- the original value. For a nonbinary modulus this is an arbitrary
2973 -- but consistent definition.
2974
2975 if Is_Modular_Integer_Type (Typ) then
2976 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2977 else pragma Assert (Is_Boolean_Type (Typ));
2978 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2979 end if;
2980
2981 Set_Is_Static_Expression (N, Stat);
2982 end;
2983 end Eval_Op_Not;
2984
2985 -------------------------------
2986 -- Eval_Qualified_Expression --
2987 -------------------------------
2988
2989 -- A qualified expression is potentially static if its subtype mark denotes
2990 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2991
2992 procedure Eval_Qualified_Expression (N : Node_Id) is
2993 Operand : constant Node_Id := Expression (N);
2994 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2995
2996 Stat : Boolean;
2997 Fold : Boolean;
2998 Hex : Boolean;
2999
3000 begin
3001 -- Can only fold if target is string or scalar and subtype is static.
3002 -- Also, do not fold if our parent is an allocator (this is because the
3003 -- qualified expression is really part of the syntactic structure of an
3004 -- allocator, and we do not want to end up with something that
3005 -- corresponds to "new 1" where the 1 is the result of folding a
3006 -- qualified expression).
3007
3008 if not Is_Static_Subtype (Target_Type)
3009 or else Nkind (Parent (N)) = N_Allocator
3010 then
3011 Check_Non_Static_Context (Operand);
3012
3013 -- If operand is known to raise constraint_error, set the flag on the
3014 -- expression so it does not get optimized away.
3015
3016 if Nkind (Operand) = N_Raise_Constraint_Error then
3017 Set_Raises_Constraint_Error (N);
3018 end if;
3019
3020 return;
3021 end if;
3022
3023 -- If not foldable we are done
3024
3025 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3026
3027 if not Fold then
3028 return;
3029
3030 -- Don't try fold if target type has constraint error bounds
3031
3032 elsif not Is_OK_Static_Subtype (Target_Type) then
3033 Set_Raises_Constraint_Error (N);
3034 return;
3035 end if;
3036
3037 -- Here we will fold, save Print_In_Hex indication
3038
3039 Hex := Nkind (Operand) = N_Integer_Literal
3040 and then Print_In_Hex (Operand);
3041
3042 -- Fold the result of qualification
3043
3044 if Is_Discrete_Type (Target_Type) then
3045 Fold_Uint (N, Expr_Value (Operand), Stat);
3046
3047 -- Preserve Print_In_Hex indication
3048
3049 if Hex and then Nkind (N) = N_Integer_Literal then
3050 Set_Print_In_Hex (N);
3051 end if;
3052
3053 elsif Is_Real_Type (Target_Type) then
3054 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
3055
3056 else
3057 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
3058
3059 if not Stat then
3060 Set_Is_Static_Expression (N, False);
3061 else
3062 Check_String_Literal_Length (N, Target_Type);
3063 end if;
3064
3065 return;
3066 end if;
3067
3068 -- The expression may be foldable but not static
3069
3070 Set_Is_Static_Expression (N, Stat);
3071
3072 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3073 Out_Of_Range (N);
3074 end if;
3075 end Eval_Qualified_Expression;
3076
3077 -----------------------
3078 -- Eval_Real_Literal --
3079 -----------------------
3080
3081 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3082 -- as static by the analyzer. The reason we did it that early is to allow
3083 -- the possibility of turning off the Is_Static_Expression flag after
3084 -- analysis, but before resolution, when integer literals are generated
3085 -- in the expander that do not correspond to static expressions.
3086
3087 procedure Eval_Real_Literal (N : Node_Id) is
3088 PK : constant Node_Kind := Nkind (Parent (N));
3089
3090 begin
3091 -- If the literal appears in a non-expression context and not as part of
3092 -- a number declaration, then it is appearing in a non-static context,
3093 -- so check it.
3094
3095 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
3096 Check_Non_Static_Context (N);
3097 end if;
3098 end Eval_Real_Literal;
3099
3100 ------------------------
3101 -- Eval_Relational_Op --
3102 ------------------------
3103
3104 -- Relational operations are static functions, so the result is static if
3105 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3106 -- the result is never static, even if the operands are.
3107
3108 -- However, for internally generated nodes, we allow string equality and
3109 -- inequality to be static. This is because we rewrite A in "ABC" as an
3110 -- equality test A = "ABC", and the former is definitely static.
3111
3112 procedure Eval_Relational_Op (N : Node_Id) is
3113 Left : constant Node_Id := Left_Opnd (N);
3114 Right : constant Node_Id := Right_Opnd (N);
3115 Typ : constant Entity_Id := Etype (Left);
3116 Otype : Entity_Id := Empty;
3117 Result : Boolean;
3118
3119 begin
3120 -- One special case to deal with first. If we can tell that the result
3121 -- will be false because the lengths of one or more index subtypes are
3122 -- compile time known and different, then we can replace the entire
3123 -- result by False. We only do this for one dimensional arrays, because
3124 -- the case of multi-dimensional arrays is rare and too much trouble. If
3125 -- one of the operands is an illegal aggregate, its type might still be
3126 -- an arbitrary composite type, so nothing to do.
3127
3128 if Is_Array_Type (Typ)
3129 and then Typ /= Any_Composite
3130 and then Number_Dimensions (Typ) = 1
3131 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
3132 then
3133 if Raises_Constraint_Error (Left)
3134 or else
3135 Raises_Constraint_Error (Right)
3136 then
3137 return;
3138 end if;
3139
3140 -- OK, we have the case where we may be able to do this fold
3141
3142 Length_Mismatch : declare
3143 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
3144 -- If Op is an expression for a constrained array with a known at
3145 -- compile time length, then Len is set to this (non-negative
3146 -- length). Otherwise Len is set to minus 1.
3147
3148 -----------------------
3149 -- Get_Static_Length --
3150 -----------------------
3151
3152 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
3153 T : Entity_Id;
3154
3155 begin
3156 -- First easy case string literal
3157
3158 if Nkind (Op) = N_String_Literal then
3159 Len := UI_From_Int (String_Length (Strval (Op)));
3160 return;
3161 end if;
3162
3163 -- Second easy case, not constrained subtype, so no length
3164
3165 if not Is_Constrained (Etype (Op)) then
3166 Len := Uint_Minus_1;
3167 return;
3168 end if;
3169
3170 -- General case
3171
3172 T := Etype (First_Index (Etype (Op)));
3173
3174 -- The simple case, both bounds are known at compile time
3175
3176 if Is_Discrete_Type (T)
3177 and then Compile_Time_Known_Value (Type_Low_Bound (T))
3178 and then Compile_Time_Known_Value (Type_High_Bound (T))
3179 then
3180 Len := UI_Max (Uint_0,
3181 Expr_Value (Type_High_Bound (T)) -
3182 Expr_Value (Type_Low_Bound (T)) + 1);
3183 return;
3184 end if;
3185
3186 -- A more complex case, where the bounds are of the form
3187 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
3188 -- either A'First or A'Last (with A an entity name), or X is an
3189 -- entity name, and the two X's are the same and K1 and K2 are
3190 -- known at compile time, in this case, the length can also be
3191 -- computed at compile time, even though the bounds are not
3192 -- known. A common case of this is e.g. (X'First .. X'First+5).
3193
3194 Extract_Length : declare
3195 procedure Decompose_Expr
3196 (Expr : Node_Id;
3197 Ent : out Entity_Id;
3198 Kind : out Character;
3199 Cons : out Uint;
3200 Orig : Boolean := True);
3201 -- Given an expression see if it is of the form given above,
3202 -- X [+/- K]. If so Ent is set to the entity in X, Kind is
3203 -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
3204 -- the value of K. If the expression is not of the required
3205 -- form, Ent is set to Empty.
3206 --
3207 -- Orig indicates whether Expr is the original expression
3208 -- to consider, or if we are handling a sub-expression
3209 -- (e.g. recursive call to Decompose_Expr).
3210
3211 --------------------
3212 -- Decompose_Expr --
3213 --------------------
3214
3215 procedure Decompose_Expr
3216 (Expr : Node_Id;
3217 Ent : out Entity_Id;
3218 Kind : out Character;
3219 Cons : out Uint;
3220 Orig : Boolean := True)
3221 is
3222 Exp : Node_Id;
3223
3224 begin
3225 Ent := Empty;
3226
3227 -- Ignored values:
3228
3229 Kind := '?';
3230 Cons := No_Uint;
3231
3232 if Nkind (Expr) = N_Op_Add
3233 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3234 then
3235 Exp := Left_Opnd (Expr);
3236 Cons := Expr_Value (Right_Opnd (Expr));
3237
3238 elsif Nkind (Expr) = N_Op_Subtract
3239 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3240 then
3241 Exp := Left_Opnd (Expr);
3242 Cons := -Expr_Value (Right_Opnd (Expr));
3243
3244 -- If the bound is a constant created to remove side
3245 -- effects, recover original expression to see if it has
3246 -- one of the recognizable forms.
3247
3248 elsif Nkind (Expr) = N_Identifier
3249 and then not Comes_From_Source (Entity (Expr))
3250 and then Ekind (Entity (Expr)) = E_Constant
3251 and then
3252 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
3253 then
3254 Exp := Expression (Parent (Entity (Expr)));
3255 Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
3256
3257 -- If original expression includes an entity, create a
3258 -- reference to it for use below.
3259
3260 if Present (Ent) then
3261 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
3262 else
3263 return;
3264 end if;
3265
3266 else
3267 -- Only consider the case of X + 0 for a full
3268 -- expression, and not when recursing, otherwise we
3269 -- may end up with evaluating expressions not known
3270 -- at compile time to 0.
3271
3272 if Orig then
3273 Exp := Expr;
3274 Cons := Uint_0;
3275 else
3276 return;
3277 end if;
3278 end if;
3279
3280 -- At this stage Exp is set to the potential X
3281
3282 if Nkind (Exp) = N_Attribute_Reference then
3283 if Attribute_Name (Exp) = Name_First then
3284 Kind := 'F';
3285 elsif Attribute_Name (Exp) = Name_Last then
3286 Kind := 'L';
3287 else
3288 return;
3289 end if;
3290
3291 Exp := Prefix (Exp);
3292
3293 else
3294 Kind := 'E';
3295 end if;
3296
3297 if Is_Entity_Name (Exp)
3298 and then Present (Entity (Exp))
3299 then
3300 Ent := Entity (Exp);
3301 end if;
3302 end Decompose_Expr;
3303
3304 -- Local Variables
3305
3306 Ent1, Ent2 : Entity_Id;
3307 Kind1, Kind2 : Character;
3308 Cons1, Cons2 : Uint;
3309
3310 -- Start of processing for Extract_Length
3311
3312 begin
3313 Decompose_Expr
3314 (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
3315 Decompose_Expr
3316 (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
3317
3318 if Present (Ent1)
3319 and then Ent1 = Ent2
3320 and then Kind1 = Kind2
3321 then
3322 Len := Cons2 - Cons1 + 1;
3323 else
3324 Len := Uint_Minus_1;
3325 end if;
3326 end Extract_Length;
3327 end Get_Static_Length;
3328
3329 -- Local Variables
3330
3331 Len_L : Uint;
3332 Len_R : Uint;
3333
3334 -- Start of processing for Length_Mismatch
3335
3336 begin
3337 Get_Static_Length (Left, Len_L);
3338 Get_Static_Length (Right, Len_R);
3339
3340 if Len_L /= Uint_Minus_1
3341 and then Len_R /= Uint_Minus_1
3342 and then Len_L /= Len_R
3343 then
3344 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
3345 Warn_On_Known_Condition (N);
3346 return;
3347 end if;
3348 end Length_Mismatch;
3349 end if;
3350
3351 declare
3352 Is_Static_Expression : Boolean;
3353
3354 Is_Foldable : Boolean;
3355 pragma Unreferenced (Is_Foldable);
3356
3357 begin
3358 -- Initialize the value of Is_Static_Expression. The value of
3359 -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
3360 -- since, even when some operand is a variable, we can still perform
3361 -- the static evaluation of the expression in some cases (for
3362 -- example, for a variable of a subtype of Integer we statically
3363 -- know that any value stored in such variable is smaller than
3364 -- Integer'Last).
3365
3366 Test_Expression_Is_Foldable
3367 (N, Left, Right, Is_Static_Expression, Is_Foldable);
3368
3369 -- Only comparisons of scalars can give static results. In
3370 -- particular, comparisons of strings never yield a static
3371 -- result, even if both operands are static strings, except that
3372 -- as noted above, we allow equality/inequality for strings.
3373
3374 if Is_String_Type (Typ)
3375 and then not Comes_From_Source (N)
3376 and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
3377 then
3378 null;
3379
3380 elsif not Is_Scalar_Type (Typ) then
3381 Is_Static_Expression := False;
3382 Set_Is_Static_Expression (N, False);
3383 end if;
3384
3385 -- For operators on universal numeric types called as functions with
3386 -- an explicit scope, determine appropriate specific numeric type,
3387 -- and diagnose possible ambiguity.
3388
3389 if Is_Universal_Numeric_Type (Etype (Left))
3390 and then
3391 Is_Universal_Numeric_Type (Etype (Right))
3392 then
3393 Otype := Find_Universal_Operator_Type (N);
3394 end if;
3395
3396 -- For static real type expressions, do not use Compile_Time_Compare
3397 -- since it worries about run-time results which are not exact.
3398
3399 if Is_Static_Expression and then Is_Real_Type (Typ) then
3400 declare
3401 Left_Real : constant Ureal := Expr_Value_R (Left);
3402 Right_Real : constant Ureal := Expr_Value_R (Right);
3403
3404 begin
3405 case Nkind (N) is
3406 when N_Op_Eq => Result := (Left_Real = Right_Real);
3407 when N_Op_Ne => Result := (Left_Real /= Right_Real);
3408 when N_Op_Lt => Result := (Left_Real < Right_Real);
3409 when N_Op_Le => Result := (Left_Real <= Right_Real);
3410 when N_Op_Gt => Result := (Left_Real > Right_Real);
3411 when N_Op_Ge => Result := (Left_Real >= Right_Real);
3412
3413 when others =>
3414 raise Program_Error;
3415 end case;
3416
3417 Fold_Uint (N, Test (Result), True);
3418 end;
3419
3420 -- For all other cases, we use Compile_Time_Compare to do the compare
3421
3422 else
3423 declare
3424 CR : constant Compare_Result :=
3425 Compile_Time_Compare
3426 (Left, Right, Assume_Valid => False);
3427
3428 begin
3429 if CR = Unknown then
3430 return;
3431 end if;
3432
3433 case Nkind (N) is
3434 when N_Op_Eq =>
3435 if CR = EQ then
3436 Result := True;
3437 elsif CR = NE or else CR = GT or else CR = LT then
3438 Result := False;
3439 else
3440 return;
3441 end if;
3442
3443 when N_Op_Ne =>
3444 if CR = NE or else CR = GT or else CR = LT then
3445 Result := True;
3446 elsif CR = EQ then
3447 Result := False;
3448 else
3449 return;
3450 end if;
3451
3452 when N_Op_Lt =>
3453 if CR = LT then
3454 Result := True;
3455 elsif CR = EQ or else CR = GT or else CR = GE then
3456 Result := False;
3457 else
3458 return;
3459 end if;
3460
3461 when N_Op_Le =>
3462 if CR = LT or else CR = EQ or else CR = LE then
3463 Result := True;
3464 elsif CR = GT then
3465 Result := False;
3466 else
3467 return;
3468 end if;
3469
3470 when N_Op_Gt =>
3471 if CR = GT then
3472 Result := True;
3473 elsif CR = EQ or else CR = LT or else CR = LE then
3474 Result := False;
3475 else
3476 return;
3477 end if;
3478
3479 when N_Op_Ge =>
3480 if CR = GT or else CR = EQ or else CR = GE then
3481 Result := True;
3482 elsif CR = LT then
3483 Result := False;
3484 else
3485 return;
3486 end if;
3487
3488 when others =>
3489 raise Program_Error;
3490 end case;
3491 end;
3492
3493 Fold_Uint (N, Test (Result), Is_Static_Expression);
3494 end if;
3495 end;
3496
3497 -- For the case of a folded relational operator on a specific numeric
3498 -- type, freeze operand type now.
3499
3500 if Present (Otype) then
3501 Freeze_Before (N, Otype);
3502 end if;
3503
3504 Warn_On_Known_Condition (N);
3505 end Eval_Relational_Op;
3506
3507 ----------------
3508 -- Eval_Shift --
3509 ----------------
3510
3511 -- Shift operations are intrinsic operations that can never be static, so
3512 -- the only processing required is to perform the required check for a non
3513 -- static context for the two operands.
3514
3515 -- Actually we could do some compile time evaluation here some time ???
3516
3517 procedure Eval_Shift (N : Node_Id) is
3518 begin
3519 Check_Non_Static_Context (Left_Opnd (N));
3520 Check_Non_Static_Context (Right_Opnd (N));
3521 end Eval_Shift;
3522
3523 ------------------------
3524 -- Eval_Short_Circuit --
3525 ------------------------
3526
3527 -- A short circuit operation is potentially static if both operands are
3528 -- potentially static (RM 4.9 (13)).
3529
3530 procedure Eval_Short_Circuit (N : Node_Id) is
3531 Kind : constant Node_Kind := Nkind (N);
3532 Left : constant Node_Id := Left_Opnd (N);
3533 Right : constant Node_Id := Right_Opnd (N);
3534 Left_Int : Uint;
3535
3536 Rstat : constant Boolean :=
3537 Is_Static_Expression (Left)
3538 and then
3539 Is_Static_Expression (Right);
3540
3541 begin
3542 -- Short circuit operations are never static in Ada 83
3543
3544 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3545 Check_Non_Static_Context (Left);
3546 Check_Non_Static_Context (Right);
3547 return;
3548 end if;
3549
3550 -- Now look at the operands, we can't quite use the normal call to
3551 -- Test_Expression_Is_Foldable here because short circuit operations
3552 -- are a special case, they can still be foldable, even if the right
3553 -- operand raises constraint error.
3554
3555 -- If either operand is Any_Type, just propagate to result and do not
3556 -- try to fold, this prevents cascaded errors.
3557
3558 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3559 Set_Etype (N, Any_Type);
3560 return;
3561
3562 -- If left operand raises constraint error, then replace node N with
3563 -- the raise constraint error node, and we are obviously not foldable.
3564 -- Is_Static_Expression is set from the two operands in the normal way,
3565 -- and we check the right operand if it is in a non-static context.
3566
3567 elsif Raises_Constraint_Error (Left) then
3568 if not Rstat then
3569 Check_Non_Static_Context (Right);
3570 end if;
3571
3572 Rewrite_In_Raise_CE (N, Left);
3573 Set_Is_Static_Expression (N, Rstat);
3574 return;
3575
3576 -- If the result is not static, then we won't in any case fold
3577
3578 elsif not Rstat then
3579 Check_Non_Static_Context (Left);
3580 Check_Non_Static_Context (Right);
3581 return;
3582 end if;
3583
3584 -- Here the result is static, note that, unlike the normal processing
3585 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3586 -- the right operand raises constraint error, that's because it is not
3587 -- significant if the left operand is decisive.
3588
3589 Set_Is_Static_Expression (N);
3590
3591 -- It does not matter if the right operand raises constraint error if
3592 -- it will not be evaluated. So deal specially with the cases where
3593 -- the right operand is not evaluated. Note that we will fold these
3594 -- cases even if the right operand is non-static, which is fine, but
3595 -- of course in these cases the result is not potentially static.
3596
3597 Left_Int := Expr_Value (Left);
3598
3599 if (Kind = N_And_Then and then Is_False (Left_Int))
3600 or else
3601 (Kind = N_Or_Else and then Is_True (Left_Int))
3602 then
3603 Fold_Uint (N, Left_Int, Rstat);
3604 return;
3605 end if;
3606
3607 -- If first operand not decisive, then it does matter if the right
3608 -- operand raises constraint error, since it will be evaluated, so
3609 -- we simply replace the node with the right operand. Note that this
3610 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3611 -- (both are set to True in Right).
3612
3613 if Raises_Constraint_Error (Right) then
3614 Rewrite_In_Raise_CE (N, Right);
3615 Check_Non_Static_Context (Left);
3616 return;
3617 end if;
3618
3619 -- Otherwise the result depends on the right operand
3620
3621 Fold_Uint (N, Expr_Value (Right), Rstat);
3622 return;
3623 end Eval_Short_Circuit;
3624
3625 ----------------
3626 -- Eval_Slice --
3627 ----------------
3628
3629 -- Slices can never be static, so the only processing required is to check
3630 -- for non-static context if an explicit range is given.
3631
3632 procedure Eval_Slice (N : Node_Id) is
3633 Drange : constant Node_Id := Discrete_Range (N);
3634
3635 begin
3636 if Nkind (Drange) = N_Range then
3637 Check_Non_Static_Context (Low_Bound (Drange));
3638 Check_Non_Static_Context (High_Bound (Drange));
3639 end if;
3640
3641 -- A slice of the form A (subtype), when the subtype is the index of
3642 -- the type of A, is redundant, the slice can be replaced with A, and
3643 -- this is worth a warning.
3644
3645 if Is_Entity_Name (Prefix (N)) then
3646 declare
3647 E : constant Entity_Id := Entity (Prefix (N));
3648 T : constant Entity_Id := Etype (E);
3649
3650 begin
3651 if Ekind (E) = E_Constant
3652 and then Is_Array_Type (T)
3653 and then Is_Entity_Name (Drange)
3654 then
3655 if Is_Entity_Name (Original_Node (First_Index (T)))
3656 and then Entity (Original_Node (First_Index (T)))
3657 = Entity (Drange)
3658 then
3659 if Warn_On_Redundant_Constructs then
3660 Error_Msg_N ("redundant slice denotes whole array?r?", N);
3661 end if;
3662
3663 -- The following might be a useful optimization???
3664
3665 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3666 end if;
3667 end if;
3668 end;
3669 end if;
3670 end Eval_Slice;
3671
3672 -------------------------
3673 -- Eval_String_Literal --
3674 -------------------------
3675
3676 procedure Eval_String_Literal (N : Node_Id) is
3677 Typ : constant Entity_Id := Etype (N);
3678 Bas : constant Entity_Id := Base_Type (Typ);
3679 Xtp : Entity_Id;
3680 Len : Nat;
3681 Lo : Node_Id;
3682
3683 begin
3684 -- Nothing to do if error type (handles cases like default expressions
3685 -- or generics where we have not yet fully resolved the type).
3686
3687 if Bas = Any_Type or else Bas = Any_String then
3688 return;
3689 end if;
3690
3691 -- String literals are static if the subtype is static (RM 4.9(2)), so
3692 -- reset the static expression flag (it was set unconditionally in
3693 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3694 -- the subtype is static by looking at the lower bound.
3695
3696 if Ekind (Typ) = E_String_Literal_Subtype then
3697 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3698 Set_Is_Static_Expression (N, False);
3699 return;
3700 end if;
3701
3702 -- Here if Etype of string literal is normal Etype (not yet possible,
3703 -- but may be possible in future).
3704
3705 elsif not Is_OK_Static_Expression
3706 (Type_Low_Bound (Etype (First_Index (Typ))))
3707 then
3708 Set_Is_Static_Expression (N, False);
3709 return;
3710 end if;
3711
3712 -- If original node was a type conversion, then result if non-static
3713
3714 if Nkind (Original_Node (N)) = N_Type_Conversion then
3715 Set_Is_Static_Expression (N, False);
3716 return;
3717 end if;
3718
3719 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3720 -- if its bounds are outside the index base type and this index type is
3721 -- static. This can happen in only two ways. Either the string literal
3722 -- is too long, or it is null, and the lower bound is type'First. Either
3723 -- way it is the upper bound that is out of range of the index type.
3724
3725 if Ada_Version >= Ada_95 then
3726 if Is_Standard_String_Type (Bas) then
3727 Xtp := Standard_Positive;
3728 else
3729 Xtp := Etype (First_Index (Bas));
3730 end if;
3731
3732 if Ekind (Typ) = E_String_Literal_Subtype then
3733 Lo := String_Literal_Low_Bound (Typ);
3734 else
3735 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3736 end if;
3737
3738 -- Check for string too long
3739
3740 Len := String_Length (Strval (N));
3741
3742 if UI_From_Int (Len) > String_Type_Len (Bas) then
3743
3744 -- Issue message. Note that this message is a warning if the
3745 -- string literal is not marked as static (happens in some cases
3746 -- of folding strings known at compile time, but not static).
3747 -- Furthermore in such cases, we reword the message, since there
3748 -- is no string literal in the source program.
3749
3750 if Is_Static_Expression (N) then
3751 Apply_Compile_Time_Constraint_Error
3752 (N, "string literal too long for}", CE_Length_Check_Failed,
3753 Ent => Bas,
3754 Typ => First_Subtype (Bas));
3755 else
3756 Apply_Compile_Time_Constraint_Error
3757 (N, "string value too long for}", CE_Length_Check_Failed,
3758 Ent => Bas,
3759 Typ => First_Subtype (Bas),
3760 Warn => True);
3761 end if;
3762
3763 -- Test for null string not allowed
3764
3765 elsif Len = 0
3766 and then not Is_Generic_Type (Xtp)
3767 and then
3768 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3769 then
3770 -- Same specialization of message
3771
3772 if Is_Static_Expression (N) then
3773 Apply_Compile_Time_Constraint_Error
3774 (N, "null string literal not allowed for}",
3775 CE_Length_Check_Failed,
3776 Ent => Bas,
3777 Typ => First_Subtype (Bas));
3778 else
3779 Apply_Compile_Time_Constraint_Error
3780 (N, "null string value not allowed for}",
3781 CE_Length_Check_Failed,
3782 Ent => Bas,
3783 Typ => First_Subtype (Bas),
3784 Warn => True);
3785 end if;
3786 end if;
3787 end if;
3788 end Eval_String_Literal;
3789
3790 --------------------------
3791 -- Eval_Type_Conversion --
3792 --------------------------
3793
3794 -- A type conversion is potentially static if its subtype mark is for a
3795 -- static scalar subtype, and its operand expression is potentially static
3796 -- (RM 4.9(10)).
3797
3798 procedure Eval_Type_Conversion (N : Node_Id) is
3799 Operand : constant Node_Id := Expression (N);
3800 Source_Type : constant Entity_Id := Etype (Operand);
3801 Target_Type : constant Entity_Id := Etype (N);
3802
3803 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3804 -- Returns true if type T is an integer type, or if it is a fixed-point
3805 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3806 -- on the conversion node).
3807
3808 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3809 -- Returns true if type T is a floating-point type, or if it is a
3810 -- fixed-point type that is not to be treated as an integer (i.e. the
3811 -- flag Conversion_OK is not set on the conversion node).
3812
3813 ------------------------------
3814 -- To_Be_Treated_As_Integer --
3815 ------------------------------
3816
3817 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3818 begin
3819 return
3820 Is_Integer_Type (T)
3821 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3822 end To_Be_Treated_As_Integer;
3823
3824 ---------------------------
3825 -- To_Be_Treated_As_Real --
3826 ---------------------------
3827
3828 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3829 begin
3830 return
3831 Is_Floating_Point_Type (T)
3832 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3833 end To_Be_Treated_As_Real;
3834
3835 -- Local variables
3836
3837 Fold : Boolean;
3838 Stat : Boolean;
3839
3840 -- Start of processing for Eval_Type_Conversion
3841
3842 begin
3843 -- Cannot fold if target type is non-static or if semantic error
3844
3845 if not Is_Static_Subtype (Target_Type) then
3846 Check_Non_Static_Context (Operand);
3847 return;
3848 elsif Error_Posted (N) then
3849 return;
3850 end if;
3851
3852 -- If not foldable we are done
3853
3854 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3855
3856 if not Fold then
3857 return;
3858
3859 -- Don't try fold if target type has constraint error bounds
3860
3861 elsif not Is_OK_Static_Subtype (Target_Type) then
3862 Set_Raises_Constraint_Error (N);
3863 return;
3864 end if;
3865
3866 -- Remaining processing depends on operand types. Note that in the
3867 -- following type test, fixed-point counts as real unless the flag
3868 -- Conversion_OK is set, in which case it counts as integer.
3869
3870 -- Fold conversion, case of string type. The result is not static
3871
3872 if Is_String_Type (Target_Type) then
3873 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3874 return;
3875
3876 -- Fold conversion, case of integer target type
3877
3878 elsif To_Be_Treated_As_Integer (Target_Type) then
3879 declare
3880 Result : Uint;
3881
3882 begin
3883 -- Integer to integer conversion
3884
3885 if To_Be_Treated_As_Integer (Source_Type) then
3886 Result := Expr_Value (Operand);
3887
3888 -- Real to integer conversion
3889
3890 else
3891 Result := UR_To_Uint (Expr_Value_R (Operand));
3892 end if;
3893
3894 -- If fixed-point type (Conversion_OK must be set), then the
3895 -- result is logically an integer, but we must replace the
3896 -- conversion with the corresponding real literal, since the
3897 -- type from a semantic point of view is still fixed-point.
3898
3899 if Is_Fixed_Point_Type (Target_Type) then
3900 Fold_Ureal
3901 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3902
3903 -- Otherwise result is integer literal
3904
3905 else
3906 Fold_Uint (N, Result, Stat);
3907 end if;
3908 end;
3909
3910 -- Fold conversion, case of real target type
3911
3912 elsif To_Be_Treated_As_Real (Target_Type) then
3913 declare
3914 Result : Ureal;
3915
3916 begin
3917 if To_Be_Treated_As_Real (Source_Type) then
3918 Result := Expr_Value_R (Operand);
3919 else
3920 Result := UR_From_Uint (Expr_Value (Operand));
3921 end if;
3922
3923 Fold_Ureal (N, Result, Stat);
3924 end;
3925
3926 -- Enumeration types
3927
3928 else
3929 Fold_Uint (N, Expr_Value (Operand), Stat);
3930 end if;
3931
3932 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3933 Out_Of_Range (N);
3934 end if;
3935
3936 end Eval_Type_Conversion;
3937
3938 -------------------
3939 -- Eval_Unary_Op --
3940 -------------------
3941
3942 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3943 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3944
3945 procedure Eval_Unary_Op (N : Node_Id) is
3946 Right : constant Node_Id := Right_Opnd (N);
3947 Otype : Entity_Id := Empty;
3948 Stat : Boolean;
3949 Fold : Boolean;
3950
3951 begin
3952 -- If not foldable we are done
3953
3954 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3955
3956 if not Fold then
3957 return;
3958 end if;
3959
3960 if Etype (Right) = Universal_Integer
3961 or else
3962 Etype (Right) = Universal_Real
3963 then
3964 Otype := Find_Universal_Operator_Type (N);
3965 end if;
3966
3967 -- Fold for integer case
3968
3969 if Is_Integer_Type (Etype (N)) then
3970 declare
3971 Rint : constant Uint := Expr_Value (Right);
3972 Result : Uint;
3973
3974 begin
3975 -- In the case of modular unary plus and abs there is no need
3976 -- to adjust the result of the operation since if the original
3977 -- operand was in bounds the result will be in the bounds of the
3978 -- modular type. However, in the case of modular unary minus the
3979 -- result may go out of the bounds of the modular type and needs
3980 -- adjustment.
3981
3982 if Nkind (N) = N_Op_Plus then
3983 Result := Rint;
3984
3985 elsif Nkind (N) = N_Op_Minus then
3986 if Is_Modular_Integer_Type (Etype (N)) then
3987 Result := (-Rint) mod Modulus (Etype (N));
3988 else
3989 Result := (-Rint);
3990 end if;
3991
3992 else
3993 pragma Assert (Nkind (N) = N_Op_Abs);
3994 Result := abs Rint;
3995 end if;
3996
3997 Fold_Uint (N, Result, Stat);
3998 end;
3999
4000 -- Fold for real case
4001
4002 elsif Is_Real_Type (Etype (N)) then
4003 declare
4004 Rreal : constant Ureal := Expr_Value_R (Right);
4005 Result : Ureal;
4006
4007 begin
4008 if Nkind (N) = N_Op_Plus then
4009 Result := Rreal;
4010 elsif Nkind (N) = N_Op_Minus then
4011 Result := UR_Negate (Rreal);
4012 else
4013 pragma Assert (Nkind (N) = N_Op_Abs);
4014 Result := abs Rreal;
4015 end if;
4016
4017 Fold_Ureal (N, Result, Stat);
4018 end;
4019 end if;
4020
4021 -- If the operator was resolved to a specific type, make sure that type
4022 -- is frozen even if the expression is folded into a literal (which has
4023 -- a universal type).
4024
4025 if Present (Otype) then
4026 Freeze_Before (N, Otype);
4027 end if;
4028 end Eval_Unary_Op;
4029
4030 -------------------------------
4031 -- Eval_Unchecked_Conversion --
4032 -------------------------------
4033
4034 -- Unchecked conversions can never be static, so the only required
4035 -- processing is to check for a non-static context for the operand.
4036
4037 procedure Eval_Unchecked_Conversion (N : Node_Id) is
4038 begin
4039 Check_Non_Static_Context (Expression (N));
4040 end Eval_Unchecked_Conversion;
4041
4042 --------------------
4043 -- Expr_Rep_Value --
4044 --------------------
4045
4046 function Expr_Rep_Value (N : Node_Id) return Uint is
4047 Kind : constant Node_Kind := Nkind (N);
4048 Ent : Entity_Id;
4049
4050 begin
4051 if Is_Entity_Name (N) then
4052 Ent := Entity (N);
4053
4054 -- An enumeration literal that was either in the source or created
4055 -- as a result of static evaluation.
4056
4057 if Ekind (Ent) = E_Enumeration_Literal then
4058 return Enumeration_Rep (Ent);
4059
4060 -- A user defined static constant
4061
4062 else
4063 pragma Assert (Ekind (Ent) = E_Constant);
4064 return Expr_Rep_Value (Constant_Value (Ent));
4065 end if;
4066
4067 -- An integer literal that was either in the source or created as a
4068 -- result of static evaluation.
4069
4070 elsif Kind = N_Integer_Literal then
4071 return Intval (N);
4072
4073 -- A real literal for a fixed-point type. This must be the fixed-point
4074 -- case, either the literal is of a fixed-point type, or it is a bound
4075 -- of a fixed-point type, with type universal real. In either case we
4076 -- obtain the desired value from Corresponding_Integer_Value.
4077
4078 elsif Kind = N_Real_Literal then
4079 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4080 return Corresponding_Integer_Value (N);
4081
4082 -- Otherwise must be character literal
4083
4084 else
4085 pragma Assert (Kind = N_Character_Literal);
4086 Ent := Entity (N);
4087
4088 -- Since Character literals of type Standard.Character don't have any
4089 -- defining character literals built for them, they do not have their
4090 -- Entity set, so just use their Char code. Otherwise for user-
4091 -- defined character literals use their Pos value as usual which is
4092 -- the same as the Rep value.
4093
4094 if No (Ent) then
4095 return Char_Literal_Value (N);
4096 else
4097 return Enumeration_Rep (Ent);
4098 end if;
4099 end if;
4100 end Expr_Rep_Value;
4101
4102 ----------------
4103 -- Expr_Value --
4104 ----------------
4105
4106 function Expr_Value (N : Node_Id) return Uint is
4107 Kind : constant Node_Kind := Nkind (N);
4108 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
4109 Ent : Entity_Id;
4110 Val : Uint;
4111
4112 begin
4113 -- If already in cache, then we know it's compile time known and we can
4114 -- return the value that was previously stored in the cache since
4115 -- compile time known values cannot change.
4116
4117 if CV_Ent.N = N then
4118 return CV_Ent.V;
4119 end if;
4120
4121 -- Otherwise proceed to test value
4122
4123 if Is_Entity_Name (N) then
4124 Ent := Entity (N);
4125
4126 -- An enumeration literal that was either in the source or created as
4127 -- a result of static evaluation.
4128
4129 if Ekind (Ent) = E_Enumeration_Literal then
4130 Val := Enumeration_Pos (Ent);
4131
4132 -- A user defined static constant
4133
4134 else
4135 pragma Assert (Ekind (Ent) = E_Constant);
4136 Val := Expr_Value (Constant_Value (Ent));
4137 end if;
4138
4139 -- An integer literal that was either in the source or created as a
4140 -- result of static evaluation.
4141
4142 elsif Kind = N_Integer_Literal then
4143 Val := Intval (N);
4144
4145 -- A real literal for a fixed-point type. This must be the fixed-point
4146 -- case, either the literal is of a fixed-point type, or it is a bound
4147 -- of a fixed-point type, with type universal real. In either case we
4148 -- obtain the desired value from Corresponding_Integer_Value.
4149
4150 elsif Kind = N_Real_Literal then
4151 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4152 Val := Corresponding_Integer_Value (N);
4153
4154 -- Otherwise must be character literal
4155
4156 else
4157 pragma Assert (Kind = N_Character_Literal);
4158 Ent := Entity (N);
4159
4160 -- Since Character literals of type Standard.Character don't
4161 -- have any defining character literals built for them, they
4162 -- do not have their Entity set, so just use their Char
4163 -- code. Otherwise for user-defined character literals use
4164 -- their Pos value as usual.
4165
4166 if No (Ent) then
4167 Val := Char_Literal_Value (N);
4168 else
4169 Val := Enumeration_Pos (Ent);
4170 end if;
4171 end if;
4172
4173 -- Come here with Val set to value to be returned, set cache
4174
4175 CV_Ent.N := N;
4176 CV_Ent.V := Val;
4177 return Val;
4178 end Expr_Value;
4179
4180 ------------------
4181 -- Expr_Value_E --
4182 ------------------
4183
4184 function Expr_Value_E (N : Node_Id) return Entity_Id is
4185 Ent : constant Entity_Id := Entity (N);
4186 begin
4187 if Ekind (Ent) = E_Enumeration_Literal then
4188 return Ent;
4189 else
4190 pragma Assert (Ekind (Ent) = E_Constant);
4191 return Expr_Value_E (Constant_Value (Ent));
4192 end if;
4193 end Expr_Value_E;
4194
4195 ------------------
4196 -- Expr_Value_R --
4197 ------------------
4198
4199 function Expr_Value_R (N : Node_Id) return Ureal is
4200 Kind : constant Node_Kind := Nkind (N);
4201 Ent : Entity_Id;
4202
4203 begin
4204 if Kind = N_Real_Literal then
4205 return Realval (N);
4206
4207 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
4208 Ent := Entity (N);
4209 pragma Assert (Ekind (Ent) = E_Constant);
4210 return Expr_Value_R (Constant_Value (Ent));
4211
4212 elsif Kind = N_Integer_Literal then
4213 return UR_From_Uint (Expr_Value (N));
4214
4215 -- Here, we have a node that cannot be interpreted as a compile time
4216 -- constant. That is definitely an error.
4217
4218 else
4219 raise Program_Error;
4220 end if;
4221 end Expr_Value_R;
4222
4223 ------------------
4224 -- Expr_Value_S --
4225 ------------------
4226
4227 function Expr_Value_S (N : Node_Id) return Node_Id is
4228 begin
4229 if Nkind (N) = N_String_Literal then
4230 return N;
4231 else
4232 pragma Assert (Ekind (Entity (N)) = E_Constant);
4233 return Expr_Value_S (Constant_Value (Entity (N)));
4234 end if;
4235 end Expr_Value_S;
4236
4237 ----------------------------------
4238 -- Find_Universal_Operator_Type --
4239 ----------------------------------
4240
4241 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
4242 PN : constant Node_Id := Parent (N);
4243 Call : constant Node_Id := Original_Node (N);
4244 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
4245
4246 Is_Fix : constant Boolean :=
4247 Nkind (N) in N_Binary_Op
4248 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
4249 -- A mixed-mode operation in this context indicates the presence of
4250 -- fixed-point type in the designated package.
4251
4252 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
4253 -- Case where N is a relational (or membership) operator (else it is an
4254 -- arithmetic one).
4255
4256 In_Membership : constant Boolean :=
4257 Nkind (PN) in N_Membership_Test
4258 and then
4259 Nkind (Right_Opnd (PN)) = N_Range
4260 and then
4261 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
4262 and then
4263 Is_Universal_Numeric_Type
4264 (Etype (Low_Bound (Right_Opnd (PN))))
4265 and then
4266 Is_Universal_Numeric_Type
4267 (Etype (High_Bound (Right_Opnd (PN))));
4268 -- Case where N is part of a membership test with a universal range
4269
4270 E : Entity_Id;
4271 Pack : Entity_Id;
4272 Typ1 : Entity_Id := Empty;
4273 Priv_E : Entity_Id;
4274
4275 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
4276 -- Check whether one operand is a mixed-mode operation that requires the
4277 -- presence of a fixed-point type. Given that all operands are universal
4278 -- and have been constant-folded, retrieve the original function call.
4279
4280 ---------------------------
4281 -- Is_Mixed_Mode_Operand --
4282 ---------------------------
4283
4284 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
4285 Onod : constant Node_Id := Original_Node (Op);
4286 begin
4287 return Nkind (Onod) = N_Function_Call
4288 and then Present (Next_Actual (First_Actual (Onod)))
4289 and then Etype (First_Actual (Onod)) /=
4290 Etype (Next_Actual (First_Actual (Onod)));
4291 end Is_Mixed_Mode_Operand;
4292
4293 -- Start of processing for Find_Universal_Operator_Type
4294
4295 begin
4296 if Nkind (Call) /= N_Function_Call
4297 or else Nkind (Name (Call)) /= N_Expanded_Name
4298 then
4299 return Empty;
4300
4301 -- There are several cases where the context does not imply the type of
4302 -- the operands:
4303 -- - the universal expression appears in a type conversion;
4304 -- - the expression is a relational operator applied to universal
4305 -- operands;
4306 -- - the expression is a membership test with a universal operand
4307 -- and a range with universal bounds.
4308
4309 elsif Nkind (Parent (N)) = N_Type_Conversion
4310 or else Is_Relational
4311 or else In_Membership
4312 then
4313 Pack := Entity (Prefix (Name (Call)));
4314
4315 -- If the prefix is a package declared elsewhere, iterate over its
4316 -- visible entities, otherwise iterate over all declarations in the
4317 -- designated scope.
4318
4319 if Ekind (Pack) = E_Package
4320 and then not In_Open_Scopes (Pack)
4321 then
4322 Priv_E := First_Private_Entity (Pack);
4323 else
4324 Priv_E := Empty;
4325 end if;
4326
4327 Typ1 := Empty;
4328 E := First_Entity (Pack);
4329 while Present (E) and then E /= Priv_E loop
4330 if Is_Numeric_Type (E)
4331 and then Nkind (Parent (E)) /= N_Subtype_Declaration
4332 and then Comes_From_Source (E)
4333 and then Is_Integer_Type (E) = Is_Int
4334 and then (Nkind (N) in N_Unary_Op
4335 or else Is_Relational
4336 or else Is_Fixed_Point_Type (E) = Is_Fix)
4337 then
4338 if No (Typ1) then
4339 Typ1 := E;
4340
4341 -- Before emitting an error, check for the presence of a
4342 -- mixed-mode operation that specifies a fixed point type.
4343
4344 elsif Is_Relational
4345 and then
4346 (Is_Mixed_Mode_Operand (Left_Opnd (N))
4347 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
4348 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
4349
4350 then
4351 if Is_Fixed_Point_Type (E) then
4352 Typ1 := E;
4353 end if;
4354
4355 else
4356 -- More than one type of the proper class declared in P
4357
4358 Error_Msg_N ("ambiguous operation", N);
4359 Error_Msg_Sloc := Sloc (Typ1);
4360 Error_Msg_N ("\possible interpretation (inherited)#", N);
4361 Error_Msg_Sloc := Sloc (E);
4362 Error_Msg_N ("\possible interpretation (inherited)#", N);
4363 return Empty;
4364 end if;
4365 end if;
4366
4367 Next_Entity (E);
4368 end loop;
4369 end if;
4370
4371 return Typ1;
4372 end Find_Universal_Operator_Type;
4373
4374 --------------------------
4375 -- Flag_Non_Static_Expr --
4376 --------------------------
4377
4378 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
4379 begin
4380 if Error_Posted (Expr) and then not All_Errors_Mode then
4381 return;
4382 else
4383 Error_Msg_F (Msg, Expr);
4384 Why_Not_Static (Expr);
4385 end if;
4386 end Flag_Non_Static_Expr;
4387
4388 --------------
4389 -- Fold_Str --
4390 --------------
4391
4392 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
4393 Loc : constant Source_Ptr := Sloc (N);
4394 Typ : constant Entity_Id := Etype (N);
4395
4396 begin
4397 if Raises_Constraint_Error (N) then
4398 Set_Is_Static_Expression (N, Static);
4399 return;
4400 end if;
4401
4402 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
4403
4404 -- We now have the literal with the right value, both the actual type
4405 -- and the expected type of this literal are taken from the expression
4406 -- that was evaluated. So now we do the Analyze and Resolve.
4407
4408 -- Note that we have to reset Is_Static_Expression both after the
4409 -- analyze step (because Resolve will evaluate the literal, which
4410 -- will cause semantic errors if it is marked as static), and after
4411 -- the Resolve step (since Resolve in some cases resets this flag).
4412
4413 Analyze (N);
4414 Set_Is_Static_Expression (N, Static);
4415 Set_Etype (N, Typ);
4416 Resolve (N);
4417 Set_Is_Static_Expression (N, Static);
4418 end Fold_Str;
4419
4420 ---------------
4421 -- Fold_Uint --
4422 ---------------
4423
4424 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
4425 Loc : constant Source_Ptr := Sloc (N);
4426 Typ : Entity_Id := Etype (N);
4427 Ent : Entity_Id;
4428
4429 begin
4430 if Raises_Constraint_Error (N) then
4431 Set_Is_Static_Expression (N, Static);
4432 return;
4433 end if;
4434
4435 -- If we are folding a named number, retain the entity in the literal,
4436 -- for ASIS use.
4437
4438 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
4439 Ent := Entity (N);
4440 else
4441 Ent := Empty;
4442 end if;
4443
4444 if Is_Private_Type (Typ) then
4445 Typ := Full_View (Typ);
4446 end if;
4447
4448 -- For a result of type integer, substitute an N_Integer_Literal node
4449 -- for the result of the compile time evaluation of the expression.
4450 -- For ASIS use, set a link to the original named number when not in
4451 -- a generic context.
4452
4453 if Is_Integer_Type (Typ) then
4454 Rewrite (N, Make_Integer_Literal (Loc, Val));
4455 Set_Original_Entity (N, Ent);
4456
4457 -- Otherwise we have an enumeration type, and we substitute either
4458 -- an N_Identifier or N_Character_Literal to represent the enumeration
4459 -- literal corresponding to the given value, which must always be in
4460 -- range, because appropriate tests have already been made for this.
4461
4462 else pragma Assert (Is_Enumeration_Type (Typ));
4463 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4464 end if;
4465
4466 -- We now have the literal with the right value, both the actual type
4467 -- and the expected type of this literal are taken from the expression
4468 -- that was evaluated. So now we do the Analyze and Resolve.
4469
4470 -- Note that we have to reset Is_Static_Expression both after the
4471 -- analyze step (because Resolve will evaluate the literal, which
4472 -- will cause semantic errors if it is marked as static), and after
4473 -- the Resolve step (since Resolve in some cases sets this flag).
4474
4475 Analyze (N);
4476 Set_Is_Static_Expression (N, Static);
4477 Set_Etype (N, Typ);
4478 Resolve (N);
4479 Set_Is_Static_Expression (N, Static);
4480 end Fold_Uint;
4481
4482 ----------------
4483 -- Fold_Ureal --
4484 ----------------
4485
4486 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4487 Loc : constant Source_Ptr := Sloc (N);
4488 Typ : constant Entity_Id := Etype (N);
4489 Ent : Entity_Id;
4490
4491 begin
4492 if Raises_Constraint_Error (N) then
4493 Set_Is_Static_Expression (N, Static);
4494 return;
4495 end if;
4496
4497 -- If we are folding a named number, retain the entity in the literal,
4498 -- for ASIS use.
4499
4500 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
4501 Ent := Entity (N);
4502 else
4503 Ent := Empty;
4504 end if;
4505
4506 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4507
4508 -- Set link to original named number, for ASIS use
4509
4510 Set_Original_Entity (N, Ent);
4511
4512 -- We now have the literal with the right value, both the actual type
4513 -- and the expected type of this literal are taken from the expression
4514 -- that was evaluated. So now we do the Analyze and Resolve.
4515
4516 -- Note that we have to reset Is_Static_Expression both after the
4517 -- analyze step (because Resolve will evaluate the literal, which
4518 -- will cause semantic errors if it is marked as static), and after
4519 -- the Resolve step (since Resolve in some cases sets this flag).
4520
4521 Analyze (N);
4522 Set_Is_Static_Expression (N, Static);
4523 Set_Etype (N, Typ);
4524 Resolve (N);
4525 Set_Is_Static_Expression (N, Static);
4526 end Fold_Ureal;
4527
4528 ---------------
4529 -- From_Bits --
4530 ---------------
4531
4532 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4533 V : Uint := Uint_0;
4534
4535 begin
4536 for J in 0 .. B'Last loop
4537 if B (J) then
4538 V := V + 2 ** J;
4539 end if;
4540 end loop;
4541
4542 if Non_Binary_Modulus (T) then
4543 V := V mod Modulus (T);
4544 end if;
4545
4546 return V;
4547 end From_Bits;
4548
4549 --------------------
4550 -- Get_String_Val --
4551 --------------------
4552
4553 function Get_String_Val (N : Node_Id) return Node_Id is
4554 begin
4555 if Nkind_In (N, N_String_Literal, N_Character_Literal) then
4556 return N;
4557 else
4558 pragma Assert (Is_Entity_Name (N));
4559 return Get_String_Val (Constant_Value (Entity (N)));
4560 end if;
4561 end Get_String_Val;
4562
4563 ----------------
4564 -- Initialize --
4565 ----------------
4566
4567 procedure Initialize is
4568 begin
4569 CV_Cache := (others => (Node_High_Bound, Uint_0));
4570 end Initialize;
4571
4572 --------------------
4573 -- In_Subrange_Of --
4574 --------------------
4575
4576 function In_Subrange_Of
4577 (T1 : Entity_Id;
4578 T2 : Entity_Id;
4579 Fixed_Int : Boolean := False) return Boolean
4580 is
4581 L1 : Node_Id;
4582 H1 : Node_Id;
4583
4584 L2 : Node_Id;
4585 H2 : Node_Id;
4586
4587 begin
4588 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4589 return True;
4590
4591 -- Never in range if both types are not scalar. Don't know if this can
4592 -- actually happen, but just in case.
4593
4594 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then
4595 return False;
4596
4597 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4598 -- definitely not compatible with T2.
4599
4600 elsif Is_Floating_Point_Type (T1)
4601 and then Has_Infinities (T1)
4602 and then Is_Floating_Point_Type (T2)
4603 and then not Has_Infinities (T2)
4604 then
4605 return False;
4606
4607 else
4608 L1 := Type_Low_Bound (T1);
4609 H1 := Type_High_Bound (T1);
4610
4611 L2 := Type_Low_Bound (T2);
4612 H2 := Type_High_Bound (T2);
4613
4614 -- Check bounds to see if comparison possible at compile time
4615
4616 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4617 and then
4618 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4619 then
4620 return True;
4621 end if;
4622
4623 -- If bounds not comparable at compile time, then the bounds of T2
4624 -- must be compile time known or we cannot answer the query.
4625
4626 if not Compile_Time_Known_Value (L2)
4627 or else not Compile_Time_Known_Value (H2)
4628 then
4629 return False;
4630 end if;
4631
4632 -- If the bounds of T1 are know at compile time then use these
4633 -- ones, otherwise use the bounds of the base type (which are of
4634 -- course always static).
4635
4636 if not Compile_Time_Known_Value (L1) then
4637 L1 := Type_Low_Bound (Base_Type (T1));
4638 end if;
4639
4640 if not Compile_Time_Known_Value (H1) then
4641 H1 := Type_High_Bound (Base_Type (T1));
4642 end if;
4643
4644 -- Fixed point types should be considered as such only if
4645 -- flag Fixed_Int is set to False.
4646
4647 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4648 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4649 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4650 then
4651 return
4652 Expr_Value_R (L2) <= Expr_Value_R (L1)
4653 and then
4654 Expr_Value_R (H2) >= Expr_Value_R (H1);
4655
4656 else
4657 return
4658 Expr_Value (L2) <= Expr_Value (L1)
4659 and then
4660 Expr_Value (H2) >= Expr_Value (H1);
4661
4662 end if;
4663 end if;
4664
4665 -- If any exception occurs, it means that we have some bug in the compiler
4666 -- possibly triggered by a previous error, or by some unforeseen peculiar
4667 -- occurrence. However, this is only an optimization attempt, so there is
4668 -- really no point in crashing the compiler. Instead we just decide, too
4669 -- bad, we can't figure out the answer in this case after all.
4670
4671 exception
4672 when others =>
4673
4674 -- Debug flag K disables this behavior (useful for debugging)
4675
4676 if Debug_Flag_K then
4677 raise;
4678 else
4679 return False;
4680 end if;
4681 end In_Subrange_Of;
4682
4683 -----------------
4684 -- Is_In_Range --
4685 -----------------
4686
4687 function Is_In_Range
4688 (N : Node_Id;
4689 Typ : Entity_Id;
4690 Assume_Valid : Boolean := False;
4691 Fixed_Int : Boolean := False;
4692 Int_Real : Boolean := False) return Boolean
4693 is
4694 begin
4695 return
4696 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
4697 end Is_In_Range;
4698
4699 -------------------
4700 -- Is_Null_Range --
4701 -------------------
4702
4703 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4704 Typ : constant Entity_Id := Etype (Lo);
4705
4706 begin
4707 if not Compile_Time_Known_Value (Lo)
4708 or else not Compile_Time_Known_Value (Hi)
4709 then
4710 return False;
4711 end if;
4712
4713 if Is_Discrete_Type (Typ) then
4714 return Expr_Value (Lo) > Expr_Value (Hi);
4715 else pragma Assert (Is_Real_Type (Typ));
4716 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4717 end if;
4718 end Is_Null_Range;
4719
4720 -------------------------
4721 -- Is_OK_Static_Choice --
4722 -------------------------
4723
4724 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is
4725 begin
4726 -- Check various possibilities for choice
4727
4728 -- Note: for membership tests, we test more cases than are possible
4729 -- (in particular subtype indication), but it doesn't matter because
4730 -- it just won't occur (we have already done a syntax check).
4731
4732 if Nkind (Choice) = N_Others_Choice then
4733 return True;
4734
4735 elsif Nkind (Choice) = N_Range then
4736 return Is_OK_Static_Range (Choice);
4737
4738 elsif Nkind (Choice) = N_Subtype_Indication
4739 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4740 then
4741 return Is_OK_Static_Subtype (Etype (Choice));
4742
4743 else
4744 return Is_OK_Static_Expression (Choice);
4745 end if;
4746 end Is_OK_Static_Choice;
4747
4748 ------------------------------
4749 -- Is_OK_Static_Choice_List --
4750 ------------------------------
4751
4752 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is
4753 Choice : Node_Id;
4754
4755 begin
4756 if not Is_Static_Choice_List (Choices) then
4757 return False;
4758 end if;
4759
4760 Choice := First (Choices);
4761 while Present (Choice) loop
4762 if not Is_OK_Static_Choice (Choice) then
4763 Set_Raises_Constraint_Error (Choice);
4764 return False;
4765 end if;
4766
4767 Next (Choice);
4768 end loop;
4769
4770 return True;
4771 end Is_OK_Static_Choice_List;
4772
4773 -----------------------------
4774 -- Is_OK_Static_Expression --
4775 -----------------------------
4776
4777 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4778 begin
4779 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
4780 end Is_OK_Static_Expression;
4781
4782 ------------------------
4783 -- Is_OK_Static_Range --
4784 ------------------------
4785
4786 -- A static range is a range whose bounds are static expressions, or a
4787 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4788 -- We have already converted range attribute references, so we get the
4789 -- "or" part of this rule without needing a special test.
4790
4791 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4792 begin
4793 return Is_OK_Static_Expression (Low_Bound (N))
4794 and then Is_OK_Static_Expression (High_Bound (N));
4795 end Is_OK_Static_Range;
4796
4797 --------------------------
4798 -- Is_OK_Static_Subtype --
4799 --------------------------
4800
4801 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4802 -- neither bound raises constraint error when evaluated.
4803
4804 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4805 Base_T : constant Entity_Id := Base_Type (Typ);
4806 Anc_Subt : Entity_Id;
4807
4808 begin
4809 -- First a quick check on the non static subtype flag. As described
4810 -- in further detail in Einfo, this flag is not decisive in all cases,
4811 -- but if it is set, then the subtype is definitely non-static.
4812
4813 if Is_Non_Static_Subtype (Typ) then
4814 return False;
4815 end if;
4816
4817 Anc_Subt := Ancestor_Subtype (Typ);
4818
4819 if Anc_Subt = Empty then
4820 Anc_Subt := Base_T;
4821 end if;
4822
4823 if Is_Generic_Type (Root_Type (Base_T))
4824 or else Is_Generic_Actual_Type (Base_T)
4825 then
4826 return False;
4827
4828 elsif Has_Dynamic_Predicate_Aspect (Typ) then
4829 return False;
4830
4831 -- String types
4832
4833 elsif Is_String_Type (Typ) then
4834 return
4835 Ekind (Typ) = E_String_Literal_Subtype
4836 or else
4837 (Is_OK_Static_Subtype (Component_Type (Typ))
4838 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4839
4840 -- Scalar types
4841
4842 elsif Is_Scalar_Type (Typ) then
4843 if Base_T = Typ then
4844 return True;
4845
4846 else
4847 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4848 -- Get_Type_{Low,High}_Bound.
4849
4850 return Is_OK_Static_Subtype (Anc_Subt)
4851 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4852 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4853 end if;
4854
4855 -- Types other than string and scalar types are never static
4856
4857 else
4858 return False;
4859 end if;
4860 end Is_OK_Static_Subtype;
4861
4862 ---------------------
4863 -- Is_Out_Of_Range --
4864 ---------------------
4865
4866 function Is_Out_Of_Range
4867 (N : Node_Id;
4868 Typ : Entity_Id;
4869 Assume_Valid : Boolean := False;
4870 Fixed_Int : Boolean := False;
4871 Int_Real : Boolean := False) return Boolean
4872 is
4873 begin
4874 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
4875 Out_Of_Range;
4876 end Is_Out_Of_Range;
4877
4878 ----------------------
4879 -- Is_Static_Choice --
4880 ----------------------
4881
4882 function Is_Static_Choice (Choice : Node_Id) return Boolean is
4883 begin
4884 -- Check various possibilities for choice
4885
4886 -- Note: for membership tests, we test more cases than are possible
4887 -- (in particular subtype indication), but it doesn't matter because
4888 -- it just won't occur (we have already done a syntax check).
4889
4890 if Nkind (Choice) = N_Others_Choice then
4891 return True;
4892
4893 elsif Nkind (Choice) = N_Range then
4894 return Is_Static_Range (Choice);
4895
4896 elsif Nkind (Choice) = N_Subtype_Indication
4897 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4898 then
4899 return Is_Static_Subtype (Etype (Choice));
4900
4901 else
4902 return Is_Static_Expression (Choice);
4903 end if;
4904 end Is_Static_Choice;
4905
4906 ---------------------------
4907 -- Is_Static_Choice_List --
4908 ---------------------------
4909
4910 function Is_Static_Choice_List (Choices : List_Id) return Boolean is
4911 Choice : Node_Id;
4912
4913 begin
4914 Choice := First (Choices);
4915 while Present (Choice) loop
4916 if not Is_Static_Choice (Choice) then
4917 return False;
4918 end if;
4919
4920 Next (Choice);
4921 end loop;
4922
4923 return True;
4924 end Is_Static_Choice_List;
4925
4926 ---------------------
4927 -- Is_Static_Range --
4928 ---------------------
4929
4930 -- A static range is a range whose bounds are static expressions, or a
4931 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4932 -- We have already converted range attribute references, so we get the
4933 -- "or" part of this rule without needing a special test.
4934
4935 function Is_Static_Range (N : Node_Id) return Boolean is
4936 begin
4937 return Is_Static_Expression (Low_Bound (N))
4938 and then
4939 Is_Static_Expression (High_Bound (N));
4940 end Is_Static_Range;
4941
4942 -----------------------
4943 -- Is_Static_Subtype --
4944 -----------------------
4945
4946 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4947
4948 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4949 Base_T : constant Entity_Id := Base_Type (Typ);
4950 Anc_Subt : Entity_Id;
4951
4952 begin
4953 -- First a quick check on the non static subtype flag. As described
4954 -- in further detail in Einfo, this flag is not decisive in all cases,
4955 -- but if it is set, then the subtype is definitely non-static.
4956
4957 if Is_Non_Static_Subtype (Typ) then
4958 return False;
4959 end if;
4960
4961 Anc_Subt := Ancestor_Subtype (Typ);
4962
4963 if Anc_Subt = Empty then
4964 Anc_Subt := Base_T;
4965 end if;
4966
4967 if Is_Generic_Type (Root_Type (Base_T))
4968 or else Is_Generic_Actual_Type (Base_T)
4969 then
4970 return False;
4971
4972 elsif Has_Dynamic_Predicate_Aspect (Typ) then
4973 return False;
4974
4975 -- String types
4976
4977 elsif Is_String_Type (Typ) then
4978 return
4979 Ekind (Typ) = E_String_Literal_Subtype
4980 or else (Is_Static_Subtype (Component_Type (Typ))
4981 and then Is_Static_Subtype (Etype (First_Index (Typ))));
4982
4983 -- Scalar types
4984
4985 elsif Is_Scalar_Type (Typ) then
4986 if Base_T = Typ then
4987 return True;
4988
4989 else
4990 return Is_Static_Subtype (Anc_Subt)
4991 and then Is_Static_Expression (Type_Low_Bound (Typ))
4992 and then Is_Static_Expression (Type_High_Bound (Typ));
4993 end if;
4994
4995 -- Types other than string and scalar types are never static
4996
4997 else
4998 return False;
4999 end if;
5000 end Is_Static_Subtype;
5001
5002 -------------------------------
5003 -- Is_Statically_Unevaluated --
5004 -------------------------------
5005
5006 function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is
5007 function Check_Case_Expr_Alternative
5008 (CEA : Node_Id) return Match_Result;
5009 -- We have a message emanating from the Expression of a case expression
5010 -- alternative. We examine this alternative, as follows:
5011 --
5012 -- If the selecting expression of the parent case is non-static, or
5013 -- if any of the discrete choices of the given case alternative are
5014 -- non-static or raise Constraint_Error, return Non_Static.
5015 --
5016 -- Otherwise check if the selecting expression matches any of the given
5017 -- discrete choices. If so, the alternative is executed and we return
5018 -- Match, otherwise, the alternative can never be executed, and so we
5019 -- return No_Match.
5020
5021 ---------------------------------
5022 -- Check_Case_Expr_Alternative --
5023 ---------------------------------
5024
5025 function Check_Case_Expr_Alternative
5026 (CEA : Node_Id) return Match_Result
5027 is
5028 Case_Exp : constant Node_Id := Parent (CEA);
5029 Choice : Node_Id;
5030 Prev_CEA : Node_Id;
5031
5032 begin
5033 pragma Assert (Nkind (Case_Exp) = N_Case_Expression);
5034
5035 -- Check that selecting expression is static
5036
5037 if not Is_OK_Static_Expression (Expression (Case_Exp)) then
5038 return Non_Static;
5039 end if;
5040
5041 if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then
5042 return Non_Static;
5043 end if;
5044
5045 -- All choices are now known to be static. Now see if alternative
5046 -- matches one of the choices.
5047
5048 Choice := First (Discrete_Choices (CEA));
5049 while Present (Choice) loop
5050
5051 -- Check various possibilities for choice, returning Match if we
5052 -- find the selecting value matches any of the choices. Note that
5053 -- we know we are the last choice, so we don't have to keep going.
5054
5055 if Nkind (Choice) = N_Others_Choice then
5056
5057 -- Others choice is a bit annoying, it matches if none of the
5058 -- previous alternatives matches (note that we know we are the
5059 -- last alternative in this case, so we can just go backwards
5060 -- from us to see if any previous one matches).
5061
5062 Prev_CEA := Prev (CEA);
5063 while Present (Prev_CEA) loop
5064 if Check_Case_Expr_Alternative (Prev_CEA) = Match then
5065 return No_Match;
5066 end if;
5067
5068 Prev (Prev_CEA);
5069 end loop;
5070
5071 return Match;
5072
5073 -- Else we have a normal static choice
5074
5075 elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then
5076 return Match;
5077 end if;
5078
5079 -- If we fall through, it means that the discrete choice did not
5080 -- match the selecting expression, so continue.
5081
5082 Next (Choice);
5083 end loop;
5084
5085 -- If we get through that loop then all choices were static, and none
5086 -- of them matched the selecting expression. So return No_Match.
5087
5088 return No_Match;
5089 end Check_Case_Expr_Alternative;
5090
5091 -- Local variables
5092
5093 P : Node_Id;
5094 OldP : Node_Id;
5095 Choice : Node_Id;
5096
5097 -- Start of processing for Is_Statically_Unevaluated
5098
5099 begin
5100 -- The (32.x) references here are from RM section 4.9
5101
5102 -- (32.1) An expression is statically unevaluated if it is part of ...
5103
5104 -- This means we have to climb the tree looking for one of the cases
5105
5106 P := Expr;
5107 loop
5108 OldP := P;
5109 P := Parent (P);
5110
5111 -- (32.2) The right operand of a static short-circuit control form
5112 -- whose value is determined by its left operand.
5113
5114 -- AND THEN with False as left operand
5115
5116 if Nkind (P) = N_And_Then
5117 and then Compile_Time_Known_Value (Left_Opnd (P))
5118 and then Is_False (Expr_Value (Left_Opnd (P)))
5119 then
5120 return True;
5121
5122 -- OR ELSE with True as left operand
5123
5124 elsif Nkind (P) = N_Or_Else
5125 and then Compile_Time_Known_Value (Left_Opnd (P))
5126 and then Is_True (Expr_Value (Left_Opnd (P)))
5127 then
5128 return True;
5129
5130 -- (32.3) A dependent_expression of an if_expression whose associated
5131 -- condition is static and equals False.
5132
5133 elsif Nkind (P) = N_If_Expression then
5134 declare
5135 Cond : constant Node_Id := First (Expressions (P));
5136 Texp : constant Node_Id := Next (Cond);
5137 Fexp : constant Node_Id := Next (Texp);
5138
5139 begin
5140 if Compile_Time_Known_Value (Cond) then
5141
5142 -- Condition is True and we are in the right operand
5143
5144 if Is_True (Expr_Value (Cond)) and then OldP = Fexp then
5145 return True;
5146
5147 -- Condition is False and we are in the left operand
5148
5149 elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then
5150 return True;
5151 end if;
5152 end if;
5153 end;
5154
5155 -- (32.4) A condition or dependent_expression of an if_expression
5156 -- where the condition corresponding to at least one preceding
5157 -- dependent_expression of the if_expression is static and equals
5158 -- True.
5159
5160 -- This refers to cases like
5161
5162 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5163
5164 -- But we expand elsif's out anyway, so the above looks like:
5165
5166 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5167
5168 -- So for us this is caught by the above check for the 32.3 case.
5169
5170 -- (32.5) A dependent_expression of a case_expression whose
5171 -- selecting_expression is static and whose value is not covered
5172 -- by the corresponding discrete_choice_list.
5173
5174 elsif Nkind (P) = N_Case_Expression_Alternative then
5175
5176 -- First, we have to be in the expression to suppress messages.
5177 -- If we are within one of the choices, we want the message.
5178
5179 if OldP = Expression (P) then
5180
5181 -- Statically unevaluated if alternative does not match
5182
5183 if Check_Case_Expr_Alternative (P) = No_Match then
5184 return True;
5185 end if;
5186 end if;
5187
5188 -- (32.6) A choice_expression (or a simple_expression of a range
5189 -- that occurs as a membership_choice of a membership_choice_list)
5190 -- of a static membership test that is preceded in the enclosing
5191 -- membership_choice_list by another item whose individual
5192 -- membership test (see (RM 4.5.2)) statically yields True.
5193
5194 elsif Nkind (P) in N_Membership_Test then
5195
5196 -- Only possibly unevaluated if simple expression is static
5197
5198 if not Is_OK_Static_Expression (Left_Opnd (P)) then
5199 null;
5200
5201 -- All members of the choice list must be static
5202
5203 elsif (Present (Right_Opnd (P))
5204 and then not Is_OK_Static_Choice (Right_Opnd (P)))
5205 or else (Present (Alternatives (P))
5206 and then
5207 not Is_OK_Static_Choice_List (Alternatives (P)))
5208 then
5209 null;
5210
5211 -- If expression is the one and only alternative, then it is
5212 -- definitely not statically unevaluated, so we only have to
5213 -- test the case where there are alternatives present.
5214
5215 elsif Present (Alternatives (P)) then
5216
5217 -- Look for previous matching Choice
5218
5219 Choice := First (Alternatives (P));
5220 while Present (Choice) loop
5221
5222 -- If we reached us and no previous choices matched, this
5223 -- is not the case where we are statically unevaluated.
5224
5225 exit when OldP = Choice;
5226
5227 -- If a previous choice matches, then that is the case where
5228 -- we know our choice is statically unevaluated.
5229
5230 if Choice_Matches (Left_Opnd (P), Choice) = Match then
5231 return True;
5232 end if;
5233
5234 Next (Choice);
5235 end loop;
5236
5237 -- If we fall through the loop, we were not one of the choices,
5238 -- we must have been the expression, so that is not covered by
5239 -- this rule, and we keep going.
5240
5241 null;
5242 end if;
5243 end if;
5244
5245 -- OK, not statically unevaluated at this level, see if we should
5246 -- keep climbing to look for a higher level reason.
5247
5248 -- Special case for component association in aggregates, where
5249 -- we want to keep climbing up to the parent aggregate.
5250
5251 if Nkind (P) = N_Component_Association
5252 and then Nkind (Parent (P)) = N_Aggregate
5253 then
5254 null;
5255
5256 -- All done if not still within subexpression
5257
5258 else
5259 exit when Nkind (P) not in N_Subexpr;
5260 end if;
5261 end loop;
5262
5263 -- If we fall through the loop, not one of the cases covered!
5264
5265 return False;
5266 end Is_Statically_Unevaluated;
5267
5268 --------------------
5269 -- Not_Null_Range --
5270 --------------------
5271
5272 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
5273 Typ : constant Entity_Id := Etype (Lo);
5274
5275 begin
5276 if not Compile_Time_Known_Value (Lo)
5277 or else not Compile_Time_Known_Value (Hi)
5278 then
5279 return False;
5280 end if;
5281
5282 if Is_Discrete_Type (Typ) then
5283 return Expr_Value (Lo) <= Expr_Value (Hi);
5284 else pragma Assert (Is_Real_Type (Typ));
5285 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
5286 end if;
5287 end Not_Null_Range;
5288
5289 -------------
5290 -- OK_Bits --
5291 -------------
5292
5293 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
5294 begin
5295 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5296
5297 if Bits < 500_000 then
5298 return True;
5299
5300 -- Error if this maximum is exceeded
5301
5302 else
5303 Error_Msg_N ("static value too large, capacity exceeded", N);
5304 return False;
5305 end if;
5306 end OK_Bits;
5307
5308 ------------------
5309 -- Out_Of_Range --
5310 ------------------
5311
5312 procedure Out_Of_Range (N : Node_Id) is
5313 begin
5314 -- If we have the static expression case, then this is an illegality
5315 -- in Ada 95 mode, except that in an instance, we never generate an
5316 -- error (if the error is legitimate, it was already diagnosed in the
5317 -- template).
5318
5319 if Is_Static_Expression (N)
5320 and then not In_Instance
5321 and then not In_Inlined_Body
5322 and then Ada_Version >= Ada_95
5323 then
5324 -- No message if we are statically unevaluated
5325
5326 if Is_Statically_Unevaluated (N) then
5327 null;
5328
5329 -- The expression to compute the length of a packed array is attached
5330 -- to the array type itself, and deserves a separate message.
5331
5332 elsif Nkind (Parent (N)) = N_Defining_Identifier
5333 and then Is_Array_Type (Parent (N))
5334 and then Present (Packed_Array_Impl_Type (Parent (N)))
5335 and then Present (First_Rep_Item (Parent (N)))
5336 then
5337 Error_Msg_N
5338 ("length of packed array must not exceed Integer''Last",
5339 First_Rep_Item (Parent (N)));
5340 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
5341
5342 -- All cases except the special array case
5343
5344 else
5345 Apply_Compile_Time_Constraint_Error
5346 (N, "value not in range of}", CE_Range_Check_Failed);
5347 end if;
5348
5349 -- Here we generate a warning for the Ada 83 case, or when we are in an
5350 -- instance, or when we have a non-static expression case.
5351
5352 else
5353 Apply_Compile_Time_Constraint_Error
5354 (N, "value not in range of}??", CE_Range_Check_Failed);
5355 end if;
5356 end Out_Of_Range;
5357
5358 ----------------------
5359 -- Predicates_Match --
5360 ----------------------
5361
5362 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
5363 Pred1 : Node_Id;
5364 Pred2 : Node_Id;
5365
5366 begin
5367 if Ada_Version < Ada_2012 then
5368 return True;
5369
5370 -- Both types must have predicates or lack them
5371
5372 elsif Has_Predicates (T1) /= Has_Predicates (T2) then
5373 return False;
5374
5375 -- Check matching predicates
5376
5377 else
5378 Pred1 :=
5379 Get_Rep_Item
5380 (T1, Name_Static_Predicate, Check_Parents => False);
5381 Pred2 :=
5382 Get_Rep_Item
5383 (T2, Name_Static_Predicate, Check_Parents => False);
5384
5385 -- Subtypes statically match if the predicate comes from the
5386 -- same declaration, which can only happen if one is a subtype
5387 -- of the other and has no explicit predicate.
5388
5389 -- Suppress warnings on order of actuals, which is otherwise
5390 -- triggered by one of the two calls below.
5391
5392 pragma Warnings (Off);
5393 return Pred1 = Pred2
5394 or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
5395 or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
5396 pragma Warnings (On);
5397 end if;
5398 end Predicates_Match;
5399
5400 ---------------------------------------------
5401 -- Real_Or_String_Static_Predicate_Matches --
5402 ---------------------------------------------
5403
5404 function Real_Or_String_Static_Predicate_Matches
5405 (Val : Node_Id;
5406 Typ : Entity_Id) return Boolean
5407 is
5408 Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ);
5409 -- The predicate expression from the type
5410
5411 Pfun : constant Entity_Id := Predicate_Function (Typ);
5412 -- The entity for the predicate function
5413
5414 Ent_Name : constant Name_Id := Chars (First_Formal (Pfun));
5415 -- The name of the formal of the predicate function. Occurrences of the
5416 -- type name in Expr have been rewritten as references to this formal,
5417 -- and it has a unique name, so we can identify references by this name.
5418
5419 Copy : Node_Id;
5420 -- Copy of the predicate function tree
5421
5422 function Process (N : Node_Id) return Traverse_Result;
5423 -- Function used to process nodes during the traversal in which we will
5424 -- find occurrences of the entity name, and replace such occurrences
5425 -- by a real literal with the value to be tested.
5426
5427 procedure Traverse is new Traverse_Proc (Process);
5428 -- The actual traversal procedure
5429
5430 -------------
5431 -- Process --
5432 -------------
5433
5434 function Process (N : Node_Id) return Traverse_Result is
5435 begin
5436 if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then
5437 declare
5438 Nod : constant Node_Id := New_Copy (Val);
5439 begin
5440 Set_Sloc (Nod, Sloc (N));
5441 Rewrite (N, Nod);
5442 return Skip;
5443 end;
5444
5445 else
5446 return OK;
5447 end if;
5448 end Process;
5449
5450 -- Start of processing for Real_Or_String_Static_Predicate_Matches
5451
5452 begin
5453 -- First deal with special case of inherited predicate, where the
5454 -- predicate expression looks like:
5455
5456 -- xxPredicate (typ (Ent)) and then Expr
5457
5458 -- where Expr is the predicate expression for this level, and the
5459 -- left operand is the call to evaluate the inherited predicate.
5460
5461 if Nkind (Expr) = N_And_Then
5462 and then Nkind (Left_Opnd (Expr)) = N_Function_Call
5463 and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr))))
5464 then
5465 -- OK we have the inherited case, so make a call to evaluate the
5466 -- inherited predicate. If that fails, so do we!
5467
5468 if not
5469 Real_Or_String_Static_Predicate_Matches
5470 (Val => Val,
5471 Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr))))))
5472 then
5473 return False;
5474 end if;
5475
5476 -- Use the right operand for the continued processing
5477
5478 Copy := Copy_Separate_Tree (Right_Opnd (Expr));
5479
5480 -- Case where call to predicate function appears on its own (this means
5481 -- that the predicate at this level is just inherited from the parent).
5482
5483 elsif Nkind (Expr) = N_Function_Call then
5484 declare
5485 Typ : constant Entity_Id :=
5486 Etype (First_Formal (Entity (Name (Expr))));
5487
5488 begin
5489 -- If the inherited predicate is dynamic, just ignore it. We can't
5490 -- go trying to evaluate a dynamic predicate as a static one!
5491
5492 if Has_Dynamic_Predicate_Aspect (Typ) then
5493 return True;
5494
5495 -- Otherwise inherited predicate is static, check for match
5496
5497 else
5498 return Real_Or_String_Static_Predicate_Matches (Val, Typ);
5499 end if;
5500 end;
5501
5502 -- If not just an inherited predicate, copy whole expression
5503
5504 else
5505 Copy := Copy_Separate_Tree (Expr);
5506 end if;
5507
5508 -- Now we replace occurrences of the entity by the value
5509
5510 Traverse (Copy);
5511
5512 -- And analyze the resulting static expression to see if it is True
5513
5514 Analyze_And_Resolve (Copy, Standard_Boolean);
5515 return Is_True (Expr_Value (Copy));
5516 end Real_Or_String_Static_Predicate_Matches;
5517
5518 -------------------------
5519 -- Rewrite_In_Raise_CE --
5520 -------------------------
5521
5522 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
5523 Typ : constant Entity_Id := Etype (N);
5524 Stat : constant Boolean := Is_Static_Expression (N);
5525
5526 begin
5527 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5528 -- can just clear the condition if the reason is appropriate. We do
5529 -- not do this operation if the parent has a reason other than range
5530 -- check failed, because otherwise we would change the reason.
5531
5532 if Present (Parent (N))
5533 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
5534 and then Reason (Parent (N)) =
5535 UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed))
5536 then
5537 Set_Condition (Parent (N), Empty);
5538
5539 -- Else build an explicit N_Raise_CE
5540
5541 else
5542 Rewrite (N,
5543 Make_Raise_Constraint_Error (Sloc (Exp),
5544 Reason => CE_Range_Check_Failed));
5545 Set_Raises_Constraint_Error (N);
5546 Set_Etype (N, Typ);
5547 end if;
5548
5549 -- Set proper flags in result
5550
5551 Set_Raises_Constraint_Error (N, True);
5552 Set_Is_Static_Expression (N, Stat);
5553 end Rewrite_In_Raise_CE;
5554
5555 ---------------------
5556 -- String_Type_Len --
5557 ---------------------
5558
5559 function String_Type_Len (Stype : Entity_Id) return Uint is
5560 NT : constant Entity_Id := Etype (First_Index (Stype));
5561 T : Entity_Id;
5562
5563 begin
5564 if Is_OK_Static_Subtype (NT) then
5565 T := NT;
5566 else
5567 T := Base_Type (NT);
5568 end if;
5569
5570 return Expr_Value (Type_High_Bound (T)) -
5571 Expr_Value (Type_Low_Bound (T)) + 1;
5572 end String_Type_Len;
5573
5574 ------------------------------------
5575 -- Subtypes_Statically_Compatible --
5576 ------------------------------------
5577
5578 function Subtypes_Statically_Compatible
5579 (T1 : Entity_Id;
5580 T2 : Entity_Id;
5581 Formal_Derived_Matching : Boolean := False) return Boolean
5582 is
5583 begin
5584 -- Scalar types
5585
5586 if Is_Scalar_Type (T1) then
5587
5588 -- Definitely compatible if we match
5589
5590 if Subtypes_Statically_Match (T1, T2) then
5591 return True;
5592
5593 -- If either subtype is nonstatic then they're not compatible
5594
5595 elsif not Is_OK_Static_Subtype (T1)
5596 or else
5597 not Is_OK_Static_Subtype (T2)
5598 then
5599 return False;
5600
5601 -- If either type has constraint error bounds, then consider that
5602 -- they match to avoid junk cascaded errors here.
5603
5604 elsif not Is_OK_Static_Subtype (T1)
5605 or else not Is_OK_Static_Subtype (T2)
5606 then
5607 return True;
5608
5609 -- Base types must match, but we don't check that (should we???) but
5610 -- we do at least check that both types are real, or both types are
5611 -- not real.
5612
5613 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
5614 return False;
5615
5616 -- Here we check the bounds
5617
5618 else
5619 declare
5620 LB1 : constant Node_Id := Type_Low_Bound (T1);
5621 HB1 : constant Node_Id := Type_High_Bound (T1);
5622 LB2 : constant Node_Id := Type_Low_Bound (T2);
5623 HB2 : constant Node_Id := Type_High_Bound (T2);
5624
5625 begin
5626 if Is_Real_Type (T1) then
5627 return
5628 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
5629 or else
5630 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
5631 and then
5632 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
5633
5634 else
5635 return
5636 (Expr_Value (LB1) > Expr_Value (HB1))
5637 or else
5638 (Expr_Value (LB2) <= Expr_Value (LB1)
5639 and then
5640 Expr_Value (HB1) <= Expr_Value (HB2));
5641 end if;
5642 end;
5643 end if;
5644
5645 -- Access types
5646
5647 elsif Is_Access_Type (T1) then
5648 return (not Is_Constrained (T2)
5649 or else (Subtypes_Statically_Match
5650 (Designated_Type (T1), Designated_Type (T2))))
5651 and then not (Can_Never_Be_Null (T2)
5652 and then not Can_Never_Be_Null (T1));
5653
5654 -- All other cases
5655
5656 else
5657 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
5658 or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching);
5659 end if;
5660 end Subtypes_Statically_Compatible;
5661
5662 -------------------------------
5663 -- Subtypes_Statically_Match --
5664 -------------------------------
5665
5666 -- Subtypes statically match if they have statically matching constraints
5667 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5668 -- they are the same identical constraint, or if they are static and the
5669 -- values match (RM 4.9.1(1)).
5670
5671 -- In addition, in GNAT, the object size (Esize) values of the types must
5672 -- match if they are set (unless checking an actual for a formal derived
5673 -- type). The use of 'Object_Size can cause this to be false even if the
5674 -- types would otherwise match in the RM sense.
5675
5676 function Subtypes_Statically_Match
5677 (T1 : Entity_Id;
5678 T2 : Entity_Id;
5679 Formal_Derived_Matching : Boolean := False) return Boolean
5680 is
5681 begin
5682 -- A type always statically matches itself
5683
5684 if T1 = T2 then
5685 return True;
5686
5687 -- No match if sizes different (from use of 'Object_Size). This test
5688 -- is excluded if Formal_Derived_Matching is True, as the base types
5689 -- can be different in that case and typically have different sizes
5690 -- (and Esizes can be set when Frontend_Layout_On_Target is True).
5691
5692 elsif not Formal_Derived_Matching
5693 and then Known_Static_Esize (T1)
5694 and then Known_Static_Esize (T2)
5695 and then Esize (T1) /= Esize (T2)
5696 then
5697 return False;
5698
5699 -- No match if predicates do not match
5700
5701 elsif not Predicates_Match (T1, T2) then
5702 return False;
5703
5704 -- Scalar types
5705
5706 elsif Is_Scalar_Type (T1) then
5707
5708 -- Base types must be the same
5709
5710 if Base_Type (T1) /= Base_Type (T2) then
5711 return False;
5712 end if;
5713
5714 -- A constrained numeric subtype never matches an unconstrained
5715 -- subtype, i.e. both types must be constrained or unconstrained.
5716
5717 -- To understand the requirement for this test, see RM 4.9.1(1).
5718 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5719 -- a constrained subtype with constraint bounds matching the bounds
5720 -- of its corresponding unconstrained base type. In this situation,
5721 -- Integer and Integer'Base do not statically match, even though
5722 -- they have the same bounds.
5723
5724 -- We only apply this test to types in Standard and types that appear
5725 -- in user programs. That way, we do not have to be too careful about
5726 -- setting Is_Constrained right for Itypes.
5727
5728 if Is_Numeric_Type (T1)
5729 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5730 and then (Scope (T1) = Standard_Standard
5731 or else Comes_From_Source (T1))
5732 and then (Scope (T2) = Standard_Standard
5733 or else Comes_From_Source (T2))
5734 then
5735 return False;
5736
5737 -- A generic scalar type does not statically match its base type
5738 -- (AI-311). In this case we make sure that the formals, which are
5739 -- first subtypes of their bases, are constrained.
5740
5741 elsif Is_Generic_Type (T1)
5742 and then Is_Generic_Type (T2)
5743 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5744 then
5745 return False;
5746 end if;
5747
5748 -- If there was an error in either range, then just assume the types
5749 -- statically match to avoid further junk errors.
5750
5751 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
5752 or else Error_Posted (Scalar_Range (T1))
5753 or else Error_Posted (Scalar_Range (T2))
5754 then
5755 return True;
5756 end if;
5757
5758 -- Otherwise both types have bounds that can be compared
5759
5760 declare
5761 LB1 : constant Node_Id := Type_Low_Bound (T1);
5762 HB1 : constant Node_Id := Type_High_Bound (T1);
5763 LB2 : constant Node_Id := Type_Low_Bound (T2);
5764 HB2 : constant Node_Id := Type_High_Bound (T2);
5765
5766 begin
5767 -- If the bounds are the same tree node, then match (common case)
5768
5769 if LB1 = LB2 and then HB1 = HB2 then
5770 return True;
5771
5772 -- Otherwise bounds must be static and identical value
5773
5774 else
5775 if not Is_OK_Static_Subtype (T1)
5776 or else not Is_OK_Static_Subtype (T2)
5777 then
5778 return False;
5779
5780 -- If either type has constraint error bounds, then say that
5781 -- they match to avoid junk cascaded errors here.
5782
5783 elsif not Is_OK_Static_Subtype (T1)
5784 or else not Is_OK_Static_Subtype (T2)
5785 then
5786 return True;
5787
5788 elsif Is_Real_Type (T1) then
5789 return
5790 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
5791 and then
5792 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
5793
5794 else
5795 return
5796 Expr_Value (LB1) = Expr_Value (LB2)
5797 and then
5798 Expr_Value (HB1) = Expr_Value (HB2);
5799 end if;
5800 end if;
5801 end;
5802
5803 -- Type with discriminants
5804
5805 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
5806
5807 -- Because of view exchanges in multiple instantiations, conformance
5808 -- checking might try to match a partial view of a type with no
5809 -- discriminants with a full view that has defaulted discriminants.
5810 -- In such a case, use the discriminant constraint of the full view,
5811 -- which must exist because we know that the two subtypes have the
5812 -- same base type.
5813
5814 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
5815 -- A generic actual type is declared through a subtype declaration
5816 -- and may have an inconsistent indication of the presence of
5817 -- discriminants, so check the type it renames.
5818
5819 if Is_Generic_Actual_Type (T1)
5820 and then not Has_Discriminants (Etype (T1))
5821 and then not Has_Discriminants (T2)
5822 then
5823 return True;
5824
5825 elsif In_Instance then
5826 if Is_Private_Type (T2)
5827 and then Present (Full_View (T2))
5828 and then Has_Discriminants (Full_View (T2))
5829 then
5830 return Subtypes_Statically_Match (T1, Full_View (T2));
5831
5832 elsif Is_Private_Type (T1)
5833 and then Present (Full_View (T1))
5834 and then Has_Discriminants (Full_View (T1))
5835 then
5836 return Subtypes_Statically_Match (Full_View (T1), T2);
5837
5838 else
5839 return False;
5840 end if;
5841 else
5842 return False;
5843 end if;
5844 end if;
5845
5846 declare
5847 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
5848 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
5849
5850 DA1 : Elmt_Id;
5851 DA2 : Elmt_Id;
5852
5853 begin
5854 if DL1 = DL2 then
5855 return True;
5856 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
5857 return False;
5858 end if;
5859
5860 -- Now loop through the discriminant constraints
5861
5862 -- Note: the guard here seems necessary, since it is possible at
5863 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5864
5865 if Present (DL1) and then Present (DL2) then
5866 DA1 := First_Elmt (DL1);
5867 DA2 := First_Elmt (DL2);
5868 while Present (DA1) loop
5869 declare
5870 Expr1 : constant Node_Id := Node (DA1);
5871 Expr2 : constant Node_Id := Node (DA2);
5872
5873 begin
5874 if not Is_OK_Static_Expression (Expr1)
5875 or else not Is_OK_Static_Expression (Expr2)
5876 then
5877 return False;
5878
5879 -- If either expression raised a constraint error,
5880 -- consider the expressions as matching, since this
5881 -- helps to prevent cascading errors.
5882
5883 elsif Raises_Constraint_Error (Expr1)
5884 or else Raises_Constraint_Error (Expr2)
5885 then
5886 null;
5887
5888 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
5889 return False;
5890 end if;
5891 end;
5892
5893 Next_Elmt (DA1);
5894 Next_Elmt (DA2);
5895 end loop;
5896 end if;
5897 end;
5898
5899 return True;
5900
5901 -- A definite type does not match an indefinite or classwide type.
5902 -- However, a generic type with unknown discriminants may be
5903 -- instantiated with a type with no discriminants, and conformance
5904 -- checking on an inherited operation may compare the actual with the
5905 -- subtype that renames it in the instance.
5906
5907 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
5908 then
5909 return
5910 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
5911
5912 -- Array type
5913
5914 elsif Is_Array_Type (T1) then
5915
5916 -- If either subtype is unconstrained then both must be, and if both
5917 -- are unconstrained then no further checking is needed.
5918
5919 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
5920 return not (Is_Constrained (T1) or else Is_Constrained (T2));
5921 end if;
5922
5923 -- Both subtypes are constrained, so check that the index subtypes
5924 -- statically match.
5925
5926 declare
5927 Index1 : Node_Id := First_Index (T1);
5928 Index2 : Node_Id := First_Index (T2);
5929
5930 begin
5931 while Present (Index1) loop
5932 if not
5933 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
5934 then
5935 return False;
5936 end if;
5937
5938 Next_Index (Index1);
5939 Next_Index (Index2);
5940 end loop;
5941
5942 return True;
5943 end;
5944
5945 elsif Is_Access_Type (T1) then
5946 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
5947 return False;
5948
5949 elsif Ekind_In (T1, E_Access_Subprogram_Type,
5950 E_Anonymous_Access_Subprogram_Type)
5951 then
5952 return
5953 Subtype_Conformant
5954 (Designated_Type (T1),
5955 Designated_Type (T2));
5956 else
5957 return
5958 Subtypes_Statically_Match
5959 (Designated_Type (T1),
5960 Designated_Type (T2))
5961 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
5962 end if;
5963
5964 -- All other types definitely match
5965
5966 else
5967 return True;
5968 end if;
5969 end Subtypes_Statically_Match;
5970
5971 ----------
5972 -- Test --
5973 ----------
5974
5975 function Test (Cond : Boolean) return Uint is
5976 begin
5977 if Cond then
5978 return Uint_1;
5979 else
5980 return Uint_0;
5981 end if;
5982 end Test;
5983
5984 ---------------------------------
5985 -- Test_Expression_Is_Foldable --
5986 ---------------------------------
5987
5988 -- One operand case
5989
5990 procedure Test_Expression_Is_Foldable
5991 (N : Node_Id;
5992 Op1 : Node_Id;
5993 Stat : out Boolean;
5994 Fold : out Boolean)
5995 is
5996 begin
5997 Stat := False;
5998 Fold := False;
5999
6000 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6001 return;
6002 end if;
6003
6004 -- If operand is Any_Type, just propagate to result and do not
6005 -- try to fold, this prevents cascaded errors.
6006
6007 if Etype (Op1) = Any_Type then
6008 Set_Etype (N, Any_Type);
6009 return;
6010
6011 -- If operand raises constraint error, then replace node N with the
6012 -- raise constraint error node, and we are obviously not foldable.
6013 -- Note that this replacement inherits the Is_Static_Expression flag
6014 -- from the operand.
6015
6016 elsif Raises_Constraint_Error (Op1) then
6017 Rewrite_In_Raise_CE (N, Op1);
6018 return;
6019
6020 -- If the operand is not static, then the result is not static, and
6021 -- all we have to do is to check the operand since it is now known
6022 -- to appear in a non-static context.
6023
6024 elsif not Is_Static_Expression (Op1) then
6025 Check_Non_Static_Context (Op1);
6026 Fold := Compile_Time_Known_Value (Op1);
6027 return;
6028
6029 -- An expression of a formal modular type is not foldable because
6030 -- the modulus is unknown.
6031
6032 elsif Is_Modular_Integer_Type (Etype (Op1))
6033 and then Is_Generic_Type (Etype (Op1))
6034 then
6035 Check_Non_Static_Context (Op1);
6036 return;
6037
6038 -- Here we have the case of an operand whose type is OK, which is
6039 -- static, and which does not raise constraint error, we can fold.
6040
6041 else
6042 Set_Is_Static_Expression (N);
6043 Fold := True;
6044 Stat := True;
6045 end if;
6046 end Test_Expression_Is_Foldable;
6047
6048 -- Two operand case
6049
6050 procedure Test_Expression_Is_Foldable
6051 (N : Node_Id;
6052 Op1 : Node_Id;
6053 Op2 : Node_Id;
6054 Stat : out Boolean;
6055 Fold : out Boolean;
6056 CRT_Safe : Boolean := False)
6057 is
6058 Rstat : constant Boolean := Is_Static_Expression (Op1)
6059 and then
6060 Is_Static_Expression (Op2);
6061
6062 begin
6063 Stat := False;
6064 Fold := False;
6065
6066 -- Inhibit folding if -gnatd.f flag set
6067
6068 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6069 return;
6070 end if;
6071
6072 -- If either operand is Any_Type, just propagate to result and
6073 -- do not try to fold, this prevents cascaded errors.
6074
6075 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
6076 Set_Etype (N, Any_Type);
6077 return;
6078
6079 -- If left operand raises constraint error, then replace node N with the
6080 -- Raise_Constraint_Error node, and we are obviously not foldable.
6081 -- Is_Static_Expression is set from the two operands in the normal way,
6082 -- and we check the right operand if it is in a non-static context.
6083
6084 elsif Raises_Constraint_Error (Op1) then
6085 if not Rstat then
6086 Check_Non_Static_Context (Op2);
6087 end if;
6088
6089 Rewrite_In_Raise_CE (N, Op1);
6090 Set_Is_Static_Expression (N, Rstat);
6091 return;
6092
6093 -- Similar processing for the case of the right operand. Note that we
6094 -- don't use this routine for the short-circuit case, so we do not have
6095 -- to worry about that special case here.
6096
6097 elsif Raises_Constraint_Error (Op2) then
6098 if not Rstat then
6099 Check_Non_Static_Context (Op1);
6100 end if;
6101
6102 Rewrite_In_Raise_CE (N, Op2);
6103 Set_Is_Static_Expression (N, Rstat);
6104 return;
6105
6106 -- Exclude expressions of a generic modular type, as above
6107
6108 elsif Is_Modular_Integer_Type (Etype (Op1))
6109 and then Is_Generic_Type (Etype (Op1))
6110 then
6111 Check_Non_Static_Context (Op1);
6112 return;
6113
6114 -- If result is not static, then check non-static contexts on operands
6115 -- since one of them may be static and the other one may not be static.
6116
6117 elsif not Rstat then
6118 Check_Non_Static_Context (Op1);
6119 Check_Non_Static_Context (Op2);
6120
6121 if CRT_Safe then
6122 Fold := CRT_Safe_Compile_Time_Known_Value (Op1)
6123 and then CRT_Safe_Compile_Time_Known_Value (Op2);
6124 else
6125 Fold := Compile_Time_Known_Value (Op1)
6126 and then Compile_Time_Known_Value (Op2);
6127 end if;
6128
6129 return;
6130
6131 -- Else result is static and foldable. Both operands are static, and
6132 -- neither raises constraint error, so we can definitely fold.
6133
6134 else
6135 Set_Is_Static_Expression (N);
6136 Fold := True;
6137 Stat := True;
6138 return;
6139 end if;
6140 end Test_Expression_Is_Foldable;
6141
6142 -------------------
6143 -- Test_In_Range --
6144 -------------------
6145
6146 function Test_In_Range
6147 (N : Node_Id;
6148 Typ : Entity_Id;
6149 Assume_Valid : Boolean;
6150 Fixed_Int : Boolean;
6151 Int_Real : Boolean) return Range_Membership
6152 is
6153 Val : Uint;
6154 Valr : Ureal;
6155
6156 pragma Warnings (Off, Assume_Valid);
6157 -- For now Assume_Valid is unreferenced since the current implementation
6158 -- always returns Unknown if N is not a compile time known value, but we
6159 -- keep the parameter to allow for future enhancements in which we try
6160 -- to get the information in the variable case as well.
6161
6162 begin
6163 -- If an error was posted on expression, then return Unknown, we do not
6164 -- want cascaded errors based on some false analysis of a junk node.
6165
6166 if Error_Posted (N) then
6167 return Unknown;
6168
6169 -- Expression that raises constraint error is an odd case. We certainly
6170 -- do not want to consider it to be in range. It might make sense to
6171 -- consider it always out of range, but this causes incorrect error
6172 -- messages about static expressions out of range. So we just return
6173 -- Unknown, which is always safe.
6174
6175 elsif Raises_Constraint_Error (N) then
6176 return Unknown;
6177
6178 -- Universal types have no range limits, so always in range
6179
6180 elsif Typ = Universal_Integer or else Typ = Universal_Real then
6181 return In_Range;
6182
6183 -- Never known if not scalar type. Don't know if this can actually
6184 -- happen, but our spec allows it, so we must check.
6185
6186 elsif not Is_Scalar_Type (Typ) then
6187 return Unknown;
6188
6189 -- Never known if this is a generic type, since the bounds of generic
6190 -- types are junk. Note that if we only checked for static expressions
6191 -- (instead of compile time known values) below, we would not need this
6192 -- check, because values of a generic type can never be static, but they
6193 -- can be known at compile time.
6194
6195 elsif Is_Generic_Type (Typ) then
6196 return Unknown;
6197
6198 -- Case of a known compile time value, where we can check if it is in
6199 -- the bounds of the given type.
6200
6201 elsif Compile_Time_Known_Value (N) then
6202 declare
6203 Lo : Node_Id;
6204 Hi : Node_Id;
6205
6206 LB_Known : Boolean;
6207 HB_Known : Boolean;
6208
6209 begin
6210 Lo := Type_Low_Bound (Typ);
6211 Hi := Type_High_Bound (Typ);
6212
6213 LB_Known := Compile_Time_Known_Value (Lo);
6214 HB_Known := Compile_Time_Known_Value (Hi);
6215
6216 -- Fixed point types should be considered as such only if flag
6217 -- Fixed_Int is set to False.
6218
6219 if Is_Floating_Point_Type (Typ)
6220 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
6221 or else Int_Real
6222 then
6223 Valr := Expr_Value_R (N);
6224
6225 if LB_Known and HB_Known then
6226 if Valr >= Expr_Value_R (Lo)
6227 and then
6228 Valr <= Expr_Value_R (Hi)
6229 then
6230 return In_Range;
6231 else
6232 return Out_Of_Range;
6233 end if;
6234
6235 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
6236 or else
6237 (HB_Known and then Valr > Expr_Value_R (Hi))
6238 then
6239 return Out_Of_Range;
6240
6241 else
6242 return Unknown;
6243 end if;
6244
6245 else
6246 Val := Expr_Value (N);
6247
6248 if LB_Known and HB_Known then
6249 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
6250 then
6251 return In_Range;
6252 else
6253 return Out_Of_Range;
6254 end if;
6255
6256 elsif (LB_Known and then Val < Expr_Value (Lo))
6257 or else
6258 (HB_Known and then Val > Expr_Value (Hi))
6259 then
6260 return Out_Of_Range;
6261
6262 else
6263 return Unknown;
6264 end if;
6265 end if;
6266 end;
6267
6268 -- Here for value not known at compile time. Case of expression subtype
6269 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
6270 -- In this case we know it is in range without knowing its value.
6271
6272 elsif Assume_Valid
6273 and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ))
6274 then
6275 return In_Range;
6276
6277 -- Another special case. For signed integer types, if the target type
6278 -- has Is_Known_Valid set, and the source type does not have a larger
6279 -- size, then the source value must be in range. We exclude biased
6280 -- types, because they bizarrely can generate out of range values.
6281
6282 elsif Is_Signed_Integer_Type (Etype (N))
6283 and then Is_Known_Valid (Typ)
6284 and then Esize (Etype (N)) <= Esize (Typ)
6285 and then not Has_Biased_Representation (Etype (N))
6286 then
6287 return In_Range;
6288
6289 -- For all other cases, result is unknown
6290
6291 else
6292 return Unknown;
6293 end if;
6294 end Test_In_Range;
6295
6296 --------------
6297 -- To_Bits --
6298 --------------
6299
6300 procedure To_Bits (U : Uint; B : out Bits) is
6301 begin
6302 for J in 0 .. B'Last loop
6303 B (J) := (U / (2 ** J)) mod 2 /= 0;
6304 end loop;
6305 end To_Bits;
6306
6307 --------------------
6308 -- Why_Not_Static --
6309 --------------------
6310
6311 procedure Why_Not_Static (Expr : Node_Id) is
6312 N : constant Node_Id := Original_Node (Expr);
6313 Typ : Entity_Id;
6314 E : Entity_Id;
6315 Alt : Node_Id;
6316 Exp : Node_Id;
6317
6318 procedure Why_Not_Static_List (L : List_Id);
6319 -- A version that can be called on a list of expressions. Finds all
6320 -- non-static violations in any element of the list.
6321
6322 -------------------------
6323 -- Why_Not_Static_List --
6324 -------------------------
6325
6326 procedure Why_Not_Static_List (L : List_Id) is
6327 N : Node_Id;
6328 begin
6329 if Is_Non_Empty_List (L) then
6330 N := First (L);
6331 while Present (N) loop
6332 Why_Not_Static (N);
6333 Next (N);
6334 end loop;
6335 end if;
6336 end Why_Not_Static_List;
6337
6338 -- Start of processing for Why_Not_Static
6339
6340 begin
6341 -- Ignore call on error or empty node
6342
6343 if No (Expr) or else Nkind (Expr) = N_Error then
6344 return;
6345 end if;
6346
6347 -- Preprocessing for sub expressions
6348
6349 if Nkind (Expr) in N_Subexpr then
6350
6351 -- Nothing to do if expression is static
6352
6353 if Is_OK_Static_Expression (Expr) then
6354 return;
6355 end if;
6356
6357 -- Test for constraint error raised
6358
6359 if Raises_Constraint_Error (Expr) then
6360
6361 -- Special case membership to find out which piece to flag
6362
6363 if Nkind (N) in N_Membership_Test then
6364 if Raises_Constraint_Error (Left_Opnd (N)) then
6365 Why_Not_Static (Left_Opnd (N));
6366 return;
6367
6368 elsif Present (Right_Opnd (N))
6369 and then Raises_Constraint_Error (Right_Opnd (N))
6370 then
6371 Why_Not_Static (Right_Opnd (N));
6372 return;
6373
6374 else
6375 pragma Assert (Present (Alternatives (N)));
6376
6377 Alt := First (Alternatives (N));
6378 while Present (Alt) loop
6379 if Raises_Constraint_Error (Alt) then
6380 Why_Not_Static (Alt);
6381 return;
6382 else
6383 Next (Alt);
6384 end if;
6385 end loop;
6386 end if;
6387
6388 -- Special case a range to find out which bound to flag
6389
6390 elsif Nkind (N) = N_Range then
6391 if Raises_Constraint_Error (Low_Bound (N)) then
6392 Why_Not_Static (Low_Bound (N));
6393 return;
6394
6395 elsif Raises_Constraint_Error (High_Bound (N)) then
6396 Why_Not_Static (High_Bound (N));
6397 return;
6398 end if;
6399
6400 -- Special case attribute to see which part to flag
6401
6402 elsif Nkind (N) = N_Attribute_Reference then
6403 if Raises_Constraint_Error (Prefix (N)) then
6404 Why_Not_Static (Prefix (N));
6405 return;
6406 end if;
6407
6408 if Present (Expressions (N)) then
6409 Exp := First (Expressions (N));
6410 while Present (Exp) loop
6411 if Raises_Constraint_Error (Exp) then
6412 Why_Not_Static (Exp);
6413 return;
6414 end if;
6415
6416 Next (Exp);
6417 end loop;
6418 end if;
6419
6420 -- Special case a subtype name
6421
6422 elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then
6423 Error_Msg_NE
6424 ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr));
6425 return;
6426 end if;
6427
6428 -- End of special cases
6429
6430 Error_Msg_N
6431 ("!expression raises exception, cannot be static (RM 4.9(34))",
6432 N);
6433 return;
6434 end if;
6435
6436 -- If no type, then something is pretty wrong, so ignore
6437
6438 Typ := Etype (Expr);
6439
6440 if No (Typ) then
6441 return;
6442 end if;
6443
6444 -- Type must be scalar or string type (but allow Bignum, since this
6445 -- is really a scalar type from our point of view in this diagnosis).
6446
6447 if not Is_Scalar_Type (Typ)
6448 and then not Is_String_Type (Typ)
6449 and then not Is_RTE (Typ, RE_Bignum)
6450 then
6451 Error_Msg_N
6452 ("!static expression must have scalar or string type " &
6453 "(RM 4.9(2))", N);
6454 return;
6455 end if;
6456 end if;
6457
6458 -- If we got through those checks, test particular node kind
6459
6460 case Nkind (N) is
6461
6462 -- Entity name
6463
6464 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
6465 E := Entity (N);
6466
6467 if Is_Named_Number (E) then
6468 null;
6469
6470 elsif Ekind (E) = E_Constant then
6471
6472 -- One case we can give a metter message is when we have a
6473 -- string literal created by concatenating an aggregate with
6474 -- an others expression.
6475
6476 Entity_Case : declare
6477 CV : constant Node_Id := Constant_Value (E);
6478 CO : constant Node_Id := Original_Node (CV);
6479
6480 function Is_Aggregate (N : Node_Id) return Boolean;
6481 -- See if node N came from an others aggregate, if so
6482 -- return True and set Error_Msg_Sloc to aggregate.
6483
6484 ------------------
6485 -- Is_Aggregate --
6486 ------------------
6487
6488 function Is_Aggregate (N : Node_Id) return Boolean is
6489 begin
6490 if Nkind (Original_Node (N)) = N_Aggregate then
6491 Error_Msg_Sloc := Sloc (Original_Node (N));
6492 return True;
6493
6494 elsif Is_Entity_Name (N)
6495 and then Ekind (Entity (N)) = E_Constant
6496 and then
6497 Nkind (Original_Node (Constant_Value (Entity (N)))) =
6498 N_Aggregate
6499 then
6500 Error_Msg_Sloc :=
6501 Sloc (Original_Node (Constant_Value (Entity (N))));
6502 return True;
6503
6504 else
6505 return False;
6506 end if;
6507 end Is_Aggregate;
6508
6509 -- Start of processing for Entity_Case
6510
6511 begin
6512 if Is_Aggregate (CV)
6513 or else (Nkind (CO) = N_Op_Concat
6514 and then (Is_Aggregate (Left_Opnd (CO))
6515 or else
6516 Is_Aggregate (Right_Opnd (CO))))
6517 then
6518 Error_Msg_N ("!aggregate (#) is never static", N);
6519
6520 elsif No (CV) or else not Is_Static_Expression (CV) then
6521 Error_Msg_NE
6522 ("!& is not a static constant (RM 4.9(5))", N, E);
6523 end if;
6524 end Entity_Case;
6525
6526 elsif Is_Type (E) then
6527 Error_Msg_NE
6528 ("!& is not a static subtype (RM 4.9(26))", N, E);
6529
6530 else
6531 Error_Msg_NE
6532 ("!& is not static constant or named number "
6533 & "(RM 4.9(5))", N, E);
6534 end if;
6535
6536 -- Binary operator
6537
6538 when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
6539 if Nkind (N) in N_Op_Shift then
6540 Error_Msg_N
6541 ("!shift functions are never static (RM 4.9(6,18))", N);
6542 else
6543 Why_Not_Static (Left_Opnd (N));
6544 Why_Not_Static (Right_Opnd (N));
6545 end if;
6546
6547 -- Unary operator
6548
6549 when N_Unary_Op =>
6550 Why_Not_Static (Right_Opnd (N));
6551
6552 -- Attribute reference
6553
6554 when N_Attribute_Reference =>
6555 Why_Not_Static_List (Expressions (N));
6556
6557 E := Etype (Prefix (N));
6558
6559 if E = Standard_Void_Type then
6560 return;
6561 end if;
6562
6563 -- Special case non-scalar'Size since this is a common error
6564
6565 if Attribute_Name (N) = Name_Size then
6566 Error_Msg_N
6567 ("!size attribute is only static for static scalar type "
6568 & "(RM 4.9(7,8))", N);
6569
6570 -- Flag array cases
6571
6572 elsif Is_Array_Type (E) then
6573 if not Nam_In (Attribute_Name (N), Name_First,
6574 Name_Last,
6575 Name_Length)
6576 then
6577 Error_Msg_N
6578 ("!static array attribute must be Length, First, or Last "
6579 & "(RM 4.9(8))", N);
6580
6581 -- Since we know the expression is not-static (we already
6582 -- tested for this, must mean array is not static).
6583
6584 else
6585 Error_Msg_N
6586 ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
6587 end if;
6588
6589 return;
6590
6591 -- Special case generic types, since again this is a common source
6592 -- of confusion.
6593
6594 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
6595 Error_Msg_N
6596 ("!attribute of generic type is never static "
6597 & "(RM 4.9(7,8))", N);
6598
6599 elsif Is_OK_Static_Subtype (E) then
6600 null;
6601
6602 elsif Is_Scalar_Type (E) then
6603 Error_Msg_N
6604 ("!prefix type for attribute is not static scalar subtype "
6605 & "(RM 4.9(7))", N);
6606
6607 else
6608 Error_Msg_N
6609 ("!static attribute must apply to array/scalar type "
6610 & "(RM 4.9(7,8))", N);
6611 end if;
6612
6613 -- String literal
6614
6615 when N_String_Literal =>
6616 Error_Msg_N
6617 ("!subtype of string literal is non-static (RM 4.9(4))", N);
6618
6619 -- Explicit dereference
6620
6621 when N_Explicit_Dereference =>
6622 Error_Msg_N
6623 ("!explicit dereference is never static (RM 4.9)", N);
6624
6625 -- Function call
6626
6627 when N_Function_Call =>
6628 Why_Not_Static_List (Parameter_Associations (N));
6629
6630 -- Complain about non-static function call unless we have Bignum
6631 -- which means that the underlying expression is really some
6632 -- scalar arithmetic operation.
6633
6634 if not Is_RTE (Typ, RE_Bignum) then
6635 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
6636 end if;
6637
6638 -- Parameter assocation (test actual parameter)
6639
6640 when N_Parameter_Association =>
6641 Why_Not_Static (Explicit_Actual_Parameter (N));
6642
6643 -- Indexed component
6644
6645 when N_Indexed_Component =>
6646 Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
6647
6648 -- Procedure call
6649
6650 when N_Procedure_Call_Statement =>
6651 Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
6652
6653 -- Qualified expression (test expression)
6654
6655 when N_Qualified_Expression =>
6656 Why_Not_Static (Expression (N));
6657
6658 -- Aggregate
6659
6660 when N_Aggregate | N_Extension_Aggregate =>
6661 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
6662
6663 -- Range
6664
6665 when N_Range =>
6666 Why_Not_Static (Low_Bound (N));
6667 Why_Not_Static (High_Bound (N));
6668
6669 -- Range constraint, test range expression
6670
6671 when N_Range_Constraint =>
6672 Why_Not_Static (Range_Expression (N));
6673
6674 -- Subtype indication, test constraint
6675
6676 when N_Subtype_Indication =>
6677 Why_Not_Static (Constraint (N));
6678
6679 -- Selected component
6680
6681 when N_Selected_Component =>
6682 Error_Msg_N ("!selected component is never static (RM 4.9)", N);
6683
6684 -- Slice
6685
6686 when N_Slice =>
6687 Error_Msg_N ("!slice is never static (RM 4.9)", N);
6688
6689 when N_Type_Conversion =>
6690 Why_Not_Static (Expression (N));
6691
6692 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
6693 or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
6694 then
6695 Error_Msg_N
6696 ("!static conversion requires static scalar subtype result "
6697 & "(RM 4.9(9))", N);
6698 end if;
6699
6700 -- Unchecked type conversion
6701
6702 when N_Unchecked_Type_Conversion =>
6703 Error_Msg_N
6704 ("!unchecked type conversion is never static (RM 4.9)", N);
6705
6706 -- All other cases, no reason to give
6707
6708 when others =>
6709 null;
6710
6711 end case;
6712 end Why_Not_Static;
6713
6714 end Sem_Eval;