]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/sem_eval.adb
Makefile.in: (stamp-tools): Add handling of snames.ad[sb]
[thirdparty/gcc.git] / gcc / ada / sem_eval.adb
CommitLineData
fbf5a39b 1------------------------------------------------------------------------------
996ae0b0
RK
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- S E M _ E V A L --
6-- --
7-- B o d y --
8-- --
45fc7ddb 9-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
996ae0b0
RK
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- --
b5c84c3c 13-- ware Foundation; either version 3, or (at your option) any later ver- --
996ae0b0
RK
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 --
b5c84c3c
RD
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. --
996ae0b0
RK
20-- --
21-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 22-- Extensive contributions were provided by Ada Core Technologies Inc. --
996ae0b0
RK
23-- --
24------------------------------------------------------------------------------
25
26with Atree; use Atree;
27with Checks; use Checks;
28with Debug; use Debug;
29with Einfo; use Einfo;
30with Elists; use Elists;
31with Errout; use Errout;
32with Eval_Fat; use Eval_Fat;
8cbb664e 33with Exp_Util; use Exp_Util;
0356699b 34with Lib; use Lib;
13f34a3f 35with Namet; use Namet;
996ae0b0
RK
36with Nmake; use Nmake;
37with Nlists; use Nlists;
38with Opt; use Opt;
39with Sem; use Sem;
a4100e55 40with Sem_Aux; use Sem_Aux;
996ae0b0 41with Sem_Cat; use Sem_Cat;
b5bd964f 42with Sem_Ch6; use Sem_Ch6;
996ae0b0
RK
43with Sem_Ch8; use Sem_Ch8;
44with Sem_Res; use Sem_Res;
45with Sem_Util; use Sem_Util;
46with Sem_Type; use Sem_Type;
47with Sem_Warn; use Sem_Warn;
48with Sinfo; use Sinfo;
49with Snames; use Snames;
50with Stand; use Stand;
51with Stringt; use Stringt;
07fc65c4 52with Tbuild; use Tbuild;
996ae0b0
RK
53
54package body Sem_Eval is
55
56 -----------------------------------------
57 -- Handling of Compile Time Evaluation --
58 -----------------------------------------
59
60 -- The compile time evaluation of expressions is distributed over several
f3d57416 61 -- Eval_xxx procedures. These procedures are called immediately after
996ae0b0
RK
62 -- a subexpression is resolved and is therefore accomplished in a bottom
63 -- up fashion. The flags are synthesized using the following approach.
64
65 -- Is_Static_Expression is determined by following the detailed rules
66 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
67 -- flag of the operands in many cases.
68
69 -- Raises_Constraint_Error is set if any of the operands have the flag
70 -- set or if an attempt to compute the value of the current expression
71 -- results in detection of a runtime constraint error.
72
73 -- As described in the spec, the requirement is that Is_Static_Expression
74 -- be accurately set, and in addition for nodes for which this flag is set,
75 -- Raises_Constraint_Error must also be set. Furthermore a node which has
76 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
77 -- requirement is that the expression value must be precomputed, and the
78 -- node is either a literal, or the name of a constant entity whose value
79 -- is a static expression.
80
81 -- The general approach is as follows. First compute Is_Static_Expression.
82 -- If the node is not static, then the flag is left off in the node and
83 -- we are all done. Otherwise for a static node, we test if any of the
84 -- operands will raise constraint error, and if so, propagate the flag
85 -- Raises_Constraint_Error to the result node and we are done (since the
86 -- error was already posted at a lower level).
87
88 -- For the case of a static node whose operands do not raise constraint
89 -- error, we attempt to evaluate the node. If this evaluation succeeds,
90 -- then the node is replaced by the result of this computation. If the
91 -- evaluation raises constraint error, then we rewrite the node with
92 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
93 -- to post appropriate error messages.
94
95 ----------------
96 -- Local Data --
97 ----------------
98
99 type Bits is array (Nat range <>) of Boolean;
100 -- Used to convert unsigned (modular) values for folding logical ops
101
07fc65c4
GB
102 -- The following definitions are used to maintain a cache of nodes that
103 -- have compile time known values. The cache is maintained only for
104 -- discrete types (the most common case), and is populated by calls to
105 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
106 -- since it is possible for the status to change (in particular it is
107 -- possible for a node to get replaced by a constraint error node).
108
109 CV_Bits : constant := 5;
110 -- Number of low order bits of Node_Id value used to reference entries
111 -- in the cache table.
112
113 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
114 -- Size of cache for compile time values
115
116 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
117
118 type CV_Entry is record
119 N : Node_Id;
120 V : Uint;
121 end record;
122
123 type CV_Cache_Array is array (CV_Range) of CV_Entry;
124
125 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
126 -- This is the actual cache, with entries consisting of node/value pairs,
127 -- and the impossible value Node_High_Bound used for unset entries.
128
996ae0b0
RK
129 -----------------------
130 -- Local Subprograms --
131 -----------------------
132
996ae0b0
RK
133 function From_Bits (B : Bits; T : Entity_Id) return Uint;
134 -- Converts a bit string of length B'Length to a Uint value to be used
135 -- for a target of type T, which is a modular type. This procedure
136 -- includes the necessary reduction by the modulus in the case of a
137 -- non-binary modulus (for a binary modulus, the bit string is the
138 -- right length any way so all is well).
139
140 function Get_String_Val (N : Node_Id) return Node_Id;
141 -- Given a tree node for a folded string or character value, returns
142 -- the corresponding string literal or character literal (one of the
143 -- two must be available, or the operand would not have been marked
144 -- as foldable in the earlier analysis of the operation).
145
07fc65c4
GB
146 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
147 -- Bits represents the number of bits in an integer value to be computed
148 -- (but the value has not been computed yet). If this value in Bits is
149 -- reasonable, a result of True is returned, with the implication that
150 -- the caller should go ahead and complete the calculation. If the value
151 -- in Bits is unreasonably large, then an error is posted on node N, and
152 -- False is returned (and the caller skips the proposed calculation).
153
996ae0b0
RK
154 procedure Out_Of_Range (N : Node_Id);
155 -- This procedure is called if it is determined that node N, which
156 -- appears in a non-static context, is a compile time known value
157 -- which is outside its range, i.e. the range of Etype. This is used
158 -- in contexts where this is an illegality if N is static, and should
159 -- generate a warning otherwise.
160
161 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
162 -- N and Exp are nodes representing an expression, Exp is known
163 -- to raise CE. N is rewritten in term of Exp in the optimal way.
164
165 function String_Type_Len (Stype : Entity_Id) return Uint;
166 -- Given a string type, determines the length of the index type, or,
167 -- if this index type is non-static, the length of the base type of
168 -- this index type. Note that if the string type is itself static,
169 -- then the index type is static, so the second case applies only
170 -- if the string type passed is non-static.
171
172 function Test (Cond : Boolean) return Uint;
173 pragma Inline (Test);
174 -- This function simply returns the appropriate Boolean'Pos value
175 -- corresponding to the value of Cond as a universal integer. It is
176 -- used for producing the result of the static evaluation of the
177 -- logical operators
178
179 procedure Test_Expression_Is_Foldable
180 (N : Node_Id;
181 Op1 : Node_Id;
182 Stat : out Boolean;
183 Fold : out Boolean);
184 -- Tests to see if expression N whose single operand is Op1 is foldable,
185 -- i.e. the operand value is known at compile time. If the operation is
186 -- foldable, then Fold is True on return, and Stat indicates whether
187 -- the result is static (i.e. both operands were static). Note that it
188 -- is quite possible for Fold to be True, and Stat to be False, since
189 -- there are cases in which we know the value of an operand even though
190 -- it is not technically static (e.g. the static lower bound of a range
191 -- whose upper bound is non-static).
192 --
3d5952be 193 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes a
996ae0b0
RK
194 -- call to Check_Non_Static_Context on the operand. If Fold is False on
195 -- return, then all processing is complete, and the caller should
196 -- return, since there is nothing else to do.
197
198 procedure Test_Expression_Is_Foldable
199 (N : Node_Id;
200 Op1 : Node_Id;
201 Op2 : Node_Id;
202 Stat : out Boolean;
203 Fold : out Boolean);
204 -- Same processing, except applies to an expression N with two operands
205 -- Op1 and Op2.
206
207 procedure To_Bits (U : Uint; B : out Bits);
208 -- Converts a Uint value to a bit string of length B'Length
209
210 ------------------------------
211 -- Check_Non_Static_Context --
212 ------------------------------
213
214 procedure Check_Non_Static_Context (N : Node_Id) is
fbf5a39b
AC
215 T : constant Entity_Id := Etype (N);
216 Checks_On : constant Boolean :=
996ae0b0
RK
217 not Index_Checks_Suppressed (T)
218 and not Range_Checks_Suppressed (T);
219
220 begin
fbf5a39b 221 -- Ignore cases of non-scalar types or error types
996ae0b0 222
fbf5a39b 223 if T = Any_Type or else not Is_Scalar_Type (T) then
996ae0b0 224 return;
fbf5a39b 225 end if;
996ae0b0 226
fbf5a39b
AC
227 -- At this stage we have a scalar type. If we have an expression
228 -- that raises CE, then we already issued a warning or error msg
229 -- so there is nothing more to be done in this routine.
230
231 if Raises_Constraint_Error (N) then
232 return;
233 end if;
234
235 -- Now we have a scalar type which is not marked as raising a
236 -- constraint error exception. The main purpose of this routine
237 -- is to deal with static expressions appearing in a non-static
238 -- context. That means that if we do not have a static expression
239 -- then there is not much to do. The one case that we deal with
240 -- here is that if we have a floating-point value that is out of
241 -- range, then we post a warning that an infinity will result.
242
243 if not Is_Static_Expression (N) then
244 if Is_Floating_Point_Type (T)
c800f862 245 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
fbf5a39b
AC
246 then
247 Error_Msg_N
248 ("?float value out of range, infinity will be generated", N);
249 end if;
996ae0b0 250
996ae0b0
RK
251 return;
252 end if;
253
254 -- Here we have the case of outer level static expression of
255 -- scalar type, where the processing of this procedure is needed.
256
257 -- For real types, this is where we convert the value to a machine
258 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should
259 -- only need to do this if the parent is a constant declaration,
260 -- since in other cases, gigi should do the necessary conversion
261 -- correctly, but experimentation shows that this is not the case
262 -- on all machines, in particular if we do not convert all literals
263 -- to machine values in non-static contexts, then ACVC test C490001
264 -- fails on Sparc/Solaris and SGI/Irix.
265
266 if Nkind (N) = N_Real_Literal
267 and then not Is_Machine_Number (N)
268 and then not Is_Generic_Type (Etype (N))
269 and then Etype (N) /= Universal_Real
996ae0b0
RK
270 then
271 -- Check that value is in bounds before converting to machine
272 -- number, so as not to lose case where value overflows in the
273 -- least significant bit or less. See B490001.
274
c800f862 275 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
996ae0b0
RK
276 Out_Of_Range (N);
277 return;
278 end if;
279
280 -- Note: we have to copy the node, to avoid problems with conformance
281 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
282
283 Rewrite (N, New_Copy (N));
284
285 if not Is_Floating_Point_Type (T) then
286 Set_Realval
287 (N, Corresponding_Integer_Value (N) * Small_Value (T));
288
289 elsif not UR_Is_Zero (Realval (N)) then
996ae0b0 290
fbf5a39b
AC
291 -- Note: even though RM 4.9(38) specifies biased rounding,
292 -- this has been modified by AI-100 in order to prevent
293 -- confusing differences in rounding between static and
294 -- non-static expressions. AI-100 specifies that the effect
295 -- of such rounding is implementation dependent, and in GNAT
296 -- we round to nearest even to match the run-time behavior.
996ae0b0 297
fbf5a39b
AC
298 Set_Realval
299 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
996ae0b0
RK
300 end if;
301
302 Set_Is_Machine_Number (N);
303 end if;
304
305 -- Check for out of range universal integer. This is a non-static
306 -- context, so the integer value must be in range of the runtime
307 -- representation of universal integers.
308
309 -- We do this only within an expression, because that is the only
310 -- case in which non-static universal integer values can occur, and
311 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
312 -- called in contexts like the expression of a number declaration where
313 -- we certainly want to allow out of range values.
314
315 if Etype (N) = Universal_Integer
316 and then Nkind (N) = N_Integer_Literal
317 and then Nkind (Parent (N)) in N_Subexpr
318 and then
319 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
320 or else
321 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
322 then
323 Apply_Compile_Time_Constraint_Error
07fc65c4
GB
324 (N, "non-static universal integer value out of range?",
325 CE_Range_Check_Failed);
996ae0b0
RK
326
327 -- Check out of range of base type
328
c800f862 329 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
996ae0b0
RK
330 Out_Of_Range (N);
331
c800f862
RD
332 -- Give warning if outside subtype (where one or both of the bounds of
333 -- the subtype is static). This warning is omitted if the expression
334 -- appears in a range that could be null (warnings are handled elsewhere
335 -- for this case).
996ae0b0
RK
336
337 elsif T /= Base_Type (T)
338 and then Nkind (Parent (N)) /= N_Range
339 then
c800f862 340 if Is_In_Range (N, T, Assume_Valid => True) then
996ae0b0
RK
341 null;
342
c800f862 343 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
996ae0b0 344 Apply_Compile_Time_Constraint_Error
07fc65c4 345 (N, "value not in range of}?", CE_Range_Check_Failed);
996ae0b0
RK
346
347 elsif Checks_On then
348 Enable_Range_Check (N);
349
350 else
351 Set_Do_Range_Check (N, False);
352 end if;
353 end if;
354 end Check_Non_Static_Context;
355
356 ---------------------------------
357 -- Check_String_Literal_Length --
358 ---------------------------------
359
360 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
361 begin
362 if not Raises_Constraint_Error (N)
363 and then Is_Constrained (Ttype)
364 then
365 if
366 UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
367 then
368 Apply_Compile_Time_Constraint_Error
369 (N, "string length wrong for}?",
07fc65c4 370 CE_Length_Check_Failed,
996ae0b0
RK
371 Ent => Ttype,
372 Typ => Ttype);
373 end if;
374 end if;
375 end Check_String_Literal_Length;
376
377 --------------------------
378 -- Compile_Time_Compare --
379 --------------------------
380
fbf5a39b 381 function Compile_Time_Compare
1c7717c3
AC
382 (L, R : Node_Id;
383 Assume_Valid : Boolean;
384 Rec : Boolean := False) return Compare_Result
fbf5a39b 385 is
1c7717c3
AC
386 Ltyp : Entity_Id := Etype (L);
387 Rtyp : Entity_Id := Etype (R);
388 -- These get reset to the base type for the case of entities where
389 -- Is_Known_Valid is not set. This takes care of handling possible
390 -- invalid representations using the value of the base type, in
391 -- accordance with RM 13.9.1(10).
996ae0b0
RK
392
393 procedure Compare_Decompose
394 (N : Node_Id;
395 R : out Node_Id;
396 V : out Uint);
b49365b2
RD
397 -- This procedure decomposes the node N into an expression node and a
398 -- signed offset, so that the value of N is equal to the value of R plus
399 -- the value V (which may be negative). If no such decomposition is
400 -- possible, then on return R is a copy of N, and V is set to zero.
996ae0b0
RK
401
402 function Compare_Fixup (N : Node_Id) return Node_Id;
b49365b2
RD
403 -- This function deals with replacing 'Last and 'First references with
404 -- their corresponding type bounds, which we then can compare. The
405 -- argument is the original node, the result is the identity, unless we
406 -- have a 'Last/'First reference in which case the value returned is the
407 -- appropriate type bound.
996ae0b0
RK
408
409 function Is_Same_Value (L, R : Node_Id) return Boolean;
410 -- Returns True iff L and R represent expressions that definitely
411 -- have identical (but not necessarily compile time known) values
412 -- Indeed the caller is expected to have already dealt with the
413 -- cases of compile time known values, so these are not tested here.
414
415 -----------------------
416 -- Compare_Decompose --
417 -----------------------
418
419 procedure Compare_Decompose
420 (N : Node_Id;
421 R : out Node_Id;
422 V : out Uint)
423 is
424 begin
425 if Nkind (N) = N_Op_Add
426 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
427 then
428 R := Left_Opnd (N);
429 V := Intval (Right_Opnd (N));
430 return;
431
432 elsif Nkind (N) = N_Op_Subtract
433 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
434 then
435 R := Left_Opnd (N);
436 V := UI_Negate (Intval (Right_Opnd (N)));
437 return;
438
439 elsif Nkind (N) = N_Attribute_Reference then
996ae0b0
RK
440 if Attribute_Name (N) = Name_Succ then
441 R := First (Expressions (N));
442 V := Uint_1;
443 return;
444
445 elsif Attribute_Name (N) = Name_Pred then
446 R := First (Expressions (N));
447 V := Uint_Minus_1;
448 return;
449 end if;
450 end if;
451
452 R := N;
453 V := Uint_0;
454 end Compare_Decompose;
455
456 -------------------
457 -- Compare_Fixup --
458 -------------------
459
460 function Compare_Fixup (N : Node_Id) return Node_Id is
461 Indx : Node_Id;
462 Xtyp : Entity_Id;
463 Subs : Nat;
464
465 begin
466 if Nkind (N) = N_Attribute_Reference
467 and then (Attribute_Name (N) = Name_First
468 or else
469 Attribute_Name (N) = Name_Last)
470 then
471 Xtyp := Etype (Prefix (N));
472
473 -- If we have no type, then just abandon the attempt to do
474 -- a fixup, this is probably the result of some other error.
475
476 if No (Xtyp) then
477 return N;
478 end if;
479
480 -- Dereference an access type
481
482 if Is_Access_Type (Xtyp) then
483 Xtyp := Designated_Type (Xtyp);
484 end if;
485
486 -- If we don't have an array type at this stage, something
487 -- is peculiar, e.g. another error, and we abandon the attempt
488 -- at a fixup.
489
490 if not Is_Array_Type (Xtyp) then
491 return N;
492 end if;
493
494 -- Ignore unconstrained array, since bounds are not meaningful
495
496 if not Is_Constrained (Xtyp) then
497 return N;
498 end if;
499
c3de5c4c
ES
500 if Ekind (Xtyp) = E_String_Literal_Subtype then
501 if Attribute_Name (N) = Name_First then
502 return String_Literal_Low_Bound (Xtyp);
503
504 else -- Attribute_Name (N) = Name_Last
505 return Make_Integer_Literal (Sloc (N),
506 Intval => Intval (String_Literal_Low_Bound (Xtyp))
507 + String_Literal_Length (Xtyp));
508 end if;
509 end if;
510
996ae0b0
RK
511 -- Find correct index type
512
513 Indx := First_Index (Xtyp);
514
515 if Present (Expressions (N)) then
516 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
517
518 for J in 2 .. Subs loop
519 Indx := Next_Index (Indx);
520 end loop;
521 end if;
522
523 Xtyp := Etype (Indx);
524
525 if Attribute_Name (N) = Name_First then
526 return Type_Low_Bound (Xtyp);
527
528 else -- Attribute_Name (N) = Name_Last
529 return Type_High_Bound (Xtyp);
530 end if;
531 end if;
532
533 return N;
534 end Compare_Fixup;
535
536 -------------------
537 -- Is_Same_Value --
538 -------------------
539
540 function Is_Same_Value (L, R : Node_Id) return Boolean is
541 Lf : constant Node_Id := Compare_Fixup (L);
542 Rf : constant Node_Id := Compare_Fixup (R);
543
fbf5a39b
AC
544 function Is_Same_Subscript (L, R : List_Id) return Boolean;
545 -- L, R are the Expressions values from two attribute nodes
546 -- for First or Last attributes. Either may be set to No_List
547 -- if no expressions are present (indicating subscript 1).
548 -- The result is True if both expressions represent the same
549 -- subscript (note that one case is where one subscript is
550 -- missing and the other is explicitly set to 1).
551
552 -----------------------
553 -- Is_Same_Subscript --
554 -----------------------
555
556 function Is_Same_Subscript (L, R : List_Id) return Boolean is
557 begin
558 if L = No_List then
559 if R = No_List then
560 return True;
561 else
562 return Expr_Value (First (R)) = Uint_1;
563 end if;
564
565 else
566 if R = No_List then
567 return Expr_Value (First (L)) = Uint_1;
568 else
569 return Expr_Value (First (L)) = Expr_Value (First (R));
570 end if;
571 end if;
572 end Is_Same_Subscript;
573
574 -- Start of processing for Is_Same_Value
575
996ae0b0 576 begin
b49365b2 577 -- Values are the same if they refer to the same entity and the
c800f862
RD
578 -- entity is non-volatile. This does not however apply to Float
579 -- types, since we may have two NaN values and they should never
580 -- compare equal.
996ae0b0 581
b49365b2
RD
582 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
583 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
996ae0b0 584 and then Entity (Lf) = Entity (Rf)
b49365b2 585 and then Present (Entity (Lf))
fbf5a39b 586 and then not Is_Floating_Point_Type (Etype (L))
c800f862
RD
587 and then not Is_Volatile_Reference (L)
588 and then not Is_Volatile_Reference (R)
996ae0b0
RK
589 then
590 return True;
591
592 -- Or if they are compile time known and identical
593
594 elsif Compile_Time_Known_Value (Lf)
595 and then
596 Compile_Time_Known_Value (Rf)
597 and then Expr_Value (Lf) = Expr_Value (Rf)
598 then
599 return True;
600
b49365b2
RD
601 -- False if Nkind of the two nodes is different for remaining cases
602
603 elsif Nkind (Lf) /= Nkind (Rf) then
604 return False;
605
606 -- True if both 'First or 'Last values applying to the same entity
607 -- (first and last don't change even if value does). Note that we
608 -- need this even with the calls to Compare_Fixup, to handle the
609 -- case of unconstrained array attributes where Compare_Fixup
610 -- cannot find useful bounds.
996ae0b0
RK
611
612 elsif Nkind (Lf) = N_Attribute_Reference
996ae0b0
RK
613 and then Attribute_Name (Lf) = Attribute_Name (Rf)
614 and then (Attribute_Name (Lf) = Name_First
615 or else
616 Attribute_Name (Lf) = Name_Last)
b49365b2
RD
617 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
618 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
996ae0b0 619 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
fbf5a39b 620 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
996ae0b0
RK
621 then
622 return True;
623
b49365b2
RD
624 -- True if the same selected component from the same record
625
626 elsif Nkind (Lf) = N_Selected_Component
627 and then Selector_Name (Lf) = Selector_Name (Rf)
628 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
629 then
630 return True;
631
632 -- True if the same unary operator applied to the same operand
633
634 elsif Nkind (Lf) in N_Unary_Op
635 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
636 then
637 return True;
638
8682d22c 639 -- True if the same binary operator applied to the same operands
b49365b2
RD
640
641 elsif Nkind (Lf) in N_Binary_Op
642 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
643 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
644 then
645 return True;
646
8682d22c 647 -- All other cases, we can't tell, so return False
996ae0b0
RK
648
649 else
650 return False;
651 end if;
652 end Is_Same_Value;
653
654 -- Start of processing for Compile_Time_Compare
655
656 begin
07fc65c4
GB
657 -- If either operand could raise constraint error, then we cannot
658 -- know the result at compile time (since CE may be raised!)
659
660 if not (Cannot_Raise_Constraint_Error (L)
661 and then
662 Cannot_Raise_Constraint_Error (R))
663 then
664 return Unknown;
665 end if;
666
667 -- Identical operands are most certainly equal
668
996ae0b0
RK
669 if L = R then
670 return EQ;
671
672 -- If expressions have no types, then do not attempt to determine
673 -- if they are the same, since something funny is going on. One
674 -- case in which this happens is during generic template analysis,
675 -- when bounds are not fully analyzed.
676
677 elsif No (Ltyp) or else No (Rtyp) then
678 return Unknown;
679
fbf5a39b
AC
680 -- We only attempt compile time analysis for scalar values, and
681 -- not for packed arrays represented as modular types, where the
682 -- semantics of comparison is quite different.
996ae0b0
RK
683
684 elsif not Is_Scalar_Type (Ltyp)
685 or else Is_Packed_Array_Type (Ltyp)
686 then
687 return Unknown;
688
689 -- Case where comparison involves two compile time known values
690
691 elsif Compile_Time_Known_Value (L)
692 and then Compile_Time_Known_Value (R)
693 then
694 -- For the floating-point case, we have to be a little careful, since
695 -- at compile time we are dealing with universal exact values, but at
696 -- runtime, these will be in non-exact target form. That's why the
697 -- returned results are LE and GE below instead of LT and GT.
698
699 if Is_Floating_Point_Type (Ltyp)
700 or else
701 Is_Floating_Point_Type (Rtyp)
702 then
703 declare
704 Lo : constant Ureal := Expr_Value_R (L);
705 Hi : constant Ureal := Expr_Value_R (R);
706
707 begin
708 if Lo < Hi then
709 return LE;
710 elsif Lo = Hi then
711 return EQ;
712 else
713 return GE;
714 end if;
715 end;
716
717 -- For the integer case we know exactly (note that this includes the
718 -- fixed-point case, where we know the run time integer values now)
719
720 else
721 declare
722 Lo : constant Uint := Expr_Value (L);
723 Hi : constant Uint := Expr_Value (R);
724
725 begin
726 if Lo < Hi then
727 return LT;
728 elsif Lo = Hi then
729 return EQ;
730 else
731 return GT;
732 end if;
733 end;
734 end if;
735
736 -- Cases where at least one operand is not known at compile time
737
738 else
29797f34
RD
739 -- Remaining checks apply only for non-generic discrete types
740
741 if not Is_Discrete_Type (Ltyp)
742 or else not Is_Discrete_Type (Rtyp)
743 or else Is_Generic_Type (Ltyp)
744 or else Is_Generic_Type (Rtyp)
745 then
746 return Unknown;
747 end if;
748
1c7717c3
AC
749 -- Replace types by base types for the case of entities which are
750 -- not known to have valid representations. This takes care of
751 -- properly dealing with invalid representations.
752
c800f862 753 if not Assume_Valid and then not Assume_No_Invalid_Values then
1c7717c3
AC
754 if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
755 Ltyp := Base_Type (Ltyp);
756 end if;
757
758 if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
759 Rtyp := Base_Type (Rtyp);
760 end if;
761 end if;
762
c800f862
RD
763 -- Try range analysis on variables and see if ranges are disjoint
764
765 declare
766 LOK, ROK : Boolean;
767 LLo, LHi : Uint;
768 RLo, RHi : Uint;
769
770 begin
771 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
772 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
773
774 if LOK and ROK then
775 if LHi < RLo then
776 return LT;
777
778 elsif RHi < LLo then
779 return GT;
780
781 elsif LLo = LHi
782 and then RLo = RHi
783 and then LLo = RLo
784 then
785 return EQ;
786
787 elsif LHi = RLo then
788 return LE;
789
790 elsif RHi = LLo then
791 return GE;
792 end if;
793 end if;
794 end;
795
996ae0b0
RK
796 -- Here is where we check for comparisons against maximum bounds of
797 -- types, where we know that no value can be outside the bounds of
798 -- the subtype. Note that this routine is allowed to assume that all
799 -- expressions are within their subtype bounds. Callers wishing to
800 -- deal with possibly invalid values must in any case take special
801 -- steps (e.g. conversions to larger types) to avoid this kind of
802 -- optimization, which is always considered to be valid. We do not
803 -- attempt this optimization with generic types, since the type
804 -- bounds may not be meaningful in this case.
805
29797f34 806 -- We are in danger of an infinite recursion here. It does not seem
fbf5a39b
AC
807 -- useful to go more than one level deep, so the parameter Rec is
808 -- used to protect ourselves against this infinite recursion.
809
29797f34
RD
810 if not Rec then
811
fbf5a39b
AC
812 -- See if we can get a decisive check against one operand and
813 -- a bound of the other operand (four possible tests here).
814
1c7717c3
AC
815 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
816 Assume_Valid, Rec => True) is
fbf5a39b
AC
817 when LT => return LT;
818 when LE => return LE;
819 when EQ => return LE;
820 when others => null;
821 end case;
996ae0b0 822
1c7717c3
AC
823 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
824 Assume_Valid, Rec => True) is
fbf5a39b
AC
825 when GT => return GT;
826 when GE => return GE;
827 when EQ => return GE;
828 when others => null;
829 end case;
996ae0b0 830
1c7717c3
AC
831 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
832 Assume_Valid, Rec => True) is
fbf5a39b
AC
833 when GT => return GT;
834 when GE => return GE;
835 when EQ => return GE;
836 when others => null;
837 end case;
996ae0b0 838
1c7717c3
AC
839 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
840 Assume_Valid, Rec => True) is
fbf5a39b
AC
841 when LT => return LT;
842 when LE => return LE;
843 when EQ => return LE;
844 when others => null;
845 end case;
996ae0b0
RK
846 end if;
847
848 -- Next attempt is to decompose the expressions to extract
849 -- a constant offset resulting from the use of any of the forms:
850
851 -- expr + literal
852 -- expr - literal
853 -- typ'Succ (expr)
854 -- typ'Pred (expr)
855
856 -- Then we see if the two expressions are the same value, and if so
857 -- the result is obtained by comparing the offsets.
858
859 declare
860 Lnode : Node_Id;
861 Loffs : Uint;
862 Rnode : Node_Id;
863 Roffs : Uint;
864
865 begin
866 Compare_Decompose (L, Lnode, Loffs);
867 Compare_Decompose (R, Rnode, Roffs);
868
869 if Is_Same_Value (Lnode, Rnode) then
870 if Loffs = Roffs then
871 return EQ;
872
873 elsif Loffs < Roffs then
874 return LT;
875
876 else
877 return GT;
878 end if;
29797f34
RD
879 end if;
880 end;
881
882 -- Next attempt is to see if we have an entity compared with a
883 -- compile time known value, where there is a current value
884 -- conditional for the entity which can tell us the result.
885
886 declare
887 Var : Node_Id;
888 -- Entity variable (left operand)
889
890 Val : Uint;
891 -- Value (right operand)
892
893 Inv : Boolean;
894 -- If False, we have reversed the operands
895
896 Op : Node_Kind;
897 -- Comparison operator kind from Get_Current_Value_Condition call
996ae0b0 898
29797f34
RD
899 Opn : Node_Id;
900 -- Value from Get_Current_Value_Condition call
901
902 Opv : Uint;
903 -- Value of Opn
904
905 Result : Compare_Result;
906 -- Known result before inversion
907
908 begin
909 if Is_Entity_Name (L)
910 and then Compile_Time_Known_Value (R)
911 then
912 Var := L;
913 Val := Expr_Value (R);
914 Inv := False;
915
916 elsif Is_Entity_Name (R)
917 and then Compile_Time_Known_Value (L)
918 then
919 Var := R;
920 Val := Expr_Value (L);
921 Inv := True;
922
923 -- That was the last chance at finding a compile time result
996ae0b0
RK
924
925 else
926 return Unknown;
927 end if;
29797f34
RD
928
929 Get_Current_Value_Condition (Var, Op, Opn);
930
931 -- That was the last chance, so if we got nothing return
932
933 if No (Opn) then
934 return Unknown;
935 end if;
936
937 Opv := Expr_Value (Opn);
938
939 -- We got a comparison, so we might have something interesting
940
941 -- Convert LE to LT and GE to GT, just so we have fewer cases
942
943 if Op = N_Op_Le then
944 Op := N_Op_Lt;
945 Opv := Opv + 1;
946 elsif Op = N_Op_Ge then
947 Op := N_Op_Gt;
948 Opv := Opv - 1;
949 end if;
950
951 -- Deal with equality case
952
953 if Op = N_Op_Eq then
954 if Val = Opv then
955 Result := EQ;
956 elsif Opv < Val then
957 Result := LT;
958 else
959 Result := GT;
960 end if;
961
962 -- Deal with inequality case
963
964 elsif Op = N_Op_Ne then
965 if Val = Opv then
966 Result := NE;
967 else
968 return Unknown;
969 end if;
970
971 -- Deal with greater than case
972
973 elsif Op = N_Op_Gt then
974 if Opv >= Val then
975 Result := GT;
976 elsif Opv = Val - 1 then
977 Result := GE;
978 else
979 return Unknown;
980 end if;
981
982 -- Deal with less than case
983
984 else pragma Assert (Op = N_Op_Lt);
985 if Opv <= Val then
986 Result := LT;
987 elsif Opv = Val + 1 then
988 Result := LE;
989 else
990 return Unknown;
991 end if;
992 end if;
993
994 -- Deal with inverting result
995
996 if Inv then
997 case Result is
998 when GT => return LT;
999 when GE => return LE;
1000 when LT => return GT;
1001 when LE => return GE;
1002 when others => return Result;
1003 end case;
1004 end if;
1005
1006 return Result;
996ae0b0
RK
1007 end;
1008 end if;
1009 end Compile_Time_Compare;
1010
f44fe430
RD
1011 -------------------------------
1012 -- Compile_Time_Known_Bounds --
1013 -------------------------------
1014
1015 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1016 Indx : Node_Id;
1017 Typ : Entity_Id;
1018
1019 begin
1020 if not Is_Array_Type (T) then
1021 return False;
1022 end if;
1023
1024 Indx := First_Index (T);
1025 while Present (Indx) loop
1026 Typ := Underlying_Type (Etype (Indx));
1027 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1028 return False;
1029 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1030 return False;
1031 else
1032 Next_Index (Indx);
1033 end if;
1034 end loop;
1035
1036 return True;
1037 end Compile_Time_Known_Bounds;
1038
996ae0b0
RK
1039 ------------------------------
1040 -- Compile_Time_Known_Value --
1041 ------------------------------
1042
1043 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
07fc65c4
GB
1044 K : constant Node_Kind := Nkind (Op);
1045 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
996ae0b0
RK
1046
1047 begin
1048 -- Never known at compile time if bad type or raises constraint error
1049 -- or empty (latter case occurs only as a result of a previous error)
1050
1051 if No (Op)
1052 or else Op = Error
1053 or else Etype (Op) = Any_Type
1054 or else Raises_Constraint_Error (Op)
1055 then
1056 return False;
1057 end if;
1058
597d7158
GD
1059 -- If this is not a static expression or a null literal, and we are in
1060 -- configurable run-time mode, then we consider it not known at compile
1061 -- time. This avoids anomalies where whether something is allowed with a
1062 -- given configurable run-time library depends on how good the compiler
1063 -- is at optimizing and knowing that things are constant when they are
1064 -- nonstatic.
1065
1066 if Configurable_Run_Time_Mode
1067 and then K /= N_Null
1068 and then not Is_Static_Expression (Op)
1069 then
fbf5a39b
AC
1070 return False;
1071 end if;
1072
996ae0b0
RK
1073 -- If we have an entity name, then see if it is the name of a constant
1074 -- and if so, test the corresponding constant value, or the name of
1075 -- an enumeration literal, which is always a constant.
1076
1077 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1078 declare
1079 E : constant Entity_Id := Entity (Op);
1080 V : Node_Id;
1081
1082 begin
1083 -- Never known at compile time if it is a packed array value.
1084 -- We might want to try to evaluate these at compile time one
1085 -- day, but we do not make that attempt now.
1086
1087 if Is_Packed_Array_Type (Etype (Op)) then
1088 return False;
1089 end if;
1090
1091 if Ekind (E) = E_Enumeration_Literal then
1092 return True;
1093
07fc65c4 1094 elsif Ekind (E) = E_Constant then
996ae0b0
RK
1095 V := Constant_Value (E);
1096 return Present (V) and then Compile_Time_Known_Value (V);
1097 end if;
1098 end;
1099
1100 -- We have a value, see if it is compile time known
1101
1102 else
07fc65c4 1103 -- Integer literals are worth storing in the cache
996ae0b0 1104
07fc65c4
GB
1105 if K = N_Integer_Literal then
1106 CV_Ent.N := Op;
1107 CV_Ent.V := Intval (Op);
1108 return True;
1109
1110 -- Other literals and NULL are known at compile time
1111
1112 elsif
996ae0b0
RK
1113 K = N_Character_Literal
1114 or else
1115 K = N_Real_Literal
1116 or else
1117 K = N_String_Literal
1118 or else
1119 K = N_Null
1120 then
1121 return True;
1122
1123 -- Any reference to Null_Parameter is known at compile time. No
1124 -- other attribute references (that have not already been folded)
1125 -- are known at compile time.
1126
1127 elsif K = N_Attribute_Reference then
1128 return Attribute_Name (Op) = Name_Null_Parameter;
07fc65c4 1129 end if;
996ae0b0 1130 end if;
07fc65c4
GB
1131
1132 -- If we fall through, not known at compile time
1133
1134 return False;
1135
1136 -- If we get an exception while trying to do this test, then some error
1137 -- has occurred, and we simply say that the value is not known after all
1138
1139 exception
1140 when others =>
1141 return False;
996ae0b0
RK
1142 end Compile_Time_Known_Value;
1143
1144 --------------------------------------
1145 -- Compile_Time_Known_Value_Or_Aggr --
1146 --------------------------------------
1147
1148 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1149 begin
1150 -- If we have an entity name, then see if it is the name of a constant
1151 -- and if so, test the corresponding constant value, or the name of
1152 -- an enumeration literal, which is always a constant.
1153
1154 if Is_Entity_Name (Op) then
1155 declare
1156 E : constant Entity_Id := Entity (Op);
1157 V : Node_Id;
1158
1159 begin
1160 if Ekind (E) = E_Enumeration_Literal then
1161 return True;
1162
1163 elsif Ekind (E) /= E_Constant then
1164 return False;
1165
1166 else
1167 V := Constant_Value (E);
1168 return Present (V)
1169 and then Compile_Time_Known_Value_Or_Aggr (V);
1170 end if;
1171 end;
1172
1173 -- We have a value, see if it is compile time known
1174
1175 else
1176 if Compile_Time_Known_Value (Op) then
1177 return True;
1178
1179 elsif Nkind (Op) = N_Aggregate then
1180
1181 if Present (Expressions (Op)) then
1182 declare
1183 Expr : Node_Id;
1184
1185 begin
1186 Expr := First (Expressions (Op));
1187 while Present (Expr) loop
1188 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1189 return False;
1190 end if;
1191
1192 Next (Expr);
1193 end loop;
1194 end;
1195 end if;
1196
1197 if Present (Component_Associations (Op)) then
1198 declare
1199 Cass : Node_Id;
1200
1201 begin
1202 Cass := First (Component_Associations (Op));
1203 while Present (Cass) loop
1204 if not
1205 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1206 then
1207 return False;
1208 end if;
1209
1210 Next (Cass);
1211 end loop;
1212 end;
1213 end if;
1214
1215 return True;
1216
1217 -- All other types of values are not known at compile time
1218
1219 else
1220 return False;
1221 end if;
1222
1223 end if;
1224 end Compile_Time_Known_Value_Or_Aggr;
1225
1226 -----------------
1227 -- Eval_Actual --
1228 -----------------
1229
1230 -- This is only called for actuals of functions that are not predefined
1231 -- operators (which have already been rewritten as operators at this
1232 -- stage), so the call can never be folded, and all that needs doing for
1233 -- the actual is to do the check for a non-static context.
1234
1235 procedure Eval_Actual (N : Node_Id) is
1236 begin
1237 Check_Non_Static_Context (N);
1238 end Eval_Actual;
1239
1240 --------------------
1241 -- Eval_Allocator --
1242 --------------------
1243
1244 -- Allocators are never static, so all we have to do is to do the
1245 -- check for a non-static context if an expression is present.
1246
1247 procedure Eval_Allocator (N : Node_Id) is
1248 Expr : constant Node_Id := Expression (N);
1249
1250 begin
1251 if Nkind (Expr) = N_Qualified_Expression then
1252 Check_Non_Static_Context (Expression (Expr));
1253 end if;
1254 end Eval_Allocator;
1255
1256 ------------------------
1257 -- Eval_Arithmetic_Op --
1258 ------------------------
1259
1260 -- Arithmetic operations are static functions, so the result is static
1261 -- if both operands are static (RM 4.9(7), 4.9(20)).
1262
1263 procedure Eval_Arithmetic_Op (N : Node_Id) is
1264 Left : constant Node_Id := Left_Opnd (N);
1265 Right : constant Node_Id := Right_Opnd (N);
1266 Ltype : constant Entity_Id := Etype (Left);
1267 Rtype : constant Entity_Id := Etype (Right);
1268 Stat : Boolean;
1269 Fold : Boolean;
1270
1271 begin
1272 -- If not foldable we are done
1273
1274 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1275
1276 if not Fold then
1277 return;
1278 end if;
1279
1280 -- Fold for cases where both operands are of integer type
1281
1282 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1283 declare
1284 Left_Int : constant Uint := Expr_Value (Left);
1285 Right_Int : constant Uint := Expr_Value (Right);
1286 Result : Uint;
1287
1288 begin
1289 case Nkind (N) is
1290
1291 when N_Op_Add =>
1292 Result := Left_Int + Right_Int;
1293
1294 when N_Op_Subtract =>
1295 Result := Left_Int - Right_Int;
1296
1297 when N_Op_Multiply =>
1298 if OK_Bits
1299 (N, UI_From_Int
1300 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1301 then
1302 Result := Left_Int * Right_Int;
1303 else
1304 Result := Left_Int;
1305 end if;
1306
1307 when N_Op_Divide =>
1308
1309 -- The exception Constraint_Error is raised by integer
1310 -- division, rem and mod if the right operand is zero.
1311
1312 if Right_Int = 0 then
1313 Apply_Compile_Time_Constraint_Error
fbf5a39b
AC
1314 (N, "division by zero",
1315 CE_Divide_By_Zero,
1316 Warn => not Stat);
996ae0b0 1317 return;
fbf5a39b 1318
996ae0b0
RK
1319 else
1320 Result := Left_Int / Right_Int;
1321 end if;
1322
1323 when N_Op_Mod =>
1324
1325 -- The exception Constraint_Error is raised by integer
1326 -- division, rem and mod if the right operand is zero.
1327
1328 if Right_Int = 0 then
1329 Apply_Compile_Time_Constraint_Error
fbf5a39b
AC
1330 (N, "mod with zero divisor",
1331 CE_Divide_By_Zero,
1332 Warn => not Stat);
996ae0b0
RK
1333 return;
1334 else
1335 Result := Left_Int mod Right_Int;
1336 end if;
1337
1338 when N_Op_Rem =>
1339
1340 -- The exception Constraint_Error is raised by integer
1341 -- division, rem and mod if the right operand is zero.
1342
1343 if Right_Int = 0 then
1344 Apply_Compile_Time_Constraint_Error
fbf5a39b
AC
1345 (N, "rem with zero divisor",
1346 CE_Divide_By_Zero,
1347 Warn => not Stat);
996ae0b0 1348 return;
fbf5a39b 1349
996ae0b0
RK
1350 else
1351 Result := Left_Int rem Right_Int;
1352 end if;
1353
1354 when others =>
1355 raise Program_Error;
1356 end case;
1357
1358 -- Adjust the result by the modulus if the type is a modular type
1359
1360 if Is_Modular_Integer_Type (Ltype) then
1361 Result := Result mod Modulus (Ltype);
82c80734
RD
1362
1363 -- For a signed integer type, check non-static overflow
1364
1365 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1366 declare
1367 BT : constant Entity_Id := Base_Type (Ltype);
1368 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1369 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1370 begin
1371 if Result < Lo or else Result > Hi then
1372 Apply_Compile_Time_Constraint_Error
1373 (N, "value not in range of }?",
1374 CE_Overflow_Check_Failed,
1375 Ent => BT);
1376 return;
1377 end if;
1378 end;
996ae0b0
RK
1379 end if;
1380
82c80734
RD
1381 -- If we get here we can fold the result
1382
fbf5a39b 1383 Fold_Uint (N, Result, Stat);
996ae0b0
RK
1384 end;
1385
1386 -- Cases where at least one operand is a real. We handle the cases
1387 -- of both reals, or mixed/real integer cases (the latter happen
1388 -- only for divide and multiply, and the result is always real).
1389
1390 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1391 declare
1392 Left_Real : Ureal;
1393 Right_Real : Ureal;
1394 Result : Ureal;
1395
1396 begin
1397 if Is_Real_Type (Ltype) then
1398 Left_Real := Expr_Value_R (Left);
1399 else
1400 Left_Real := UR_From_Uint (Expr_Value (Left));
1401 end if;
1402
1403 if Is_Real_Type (Rtype) then
1404 Right_Real := Expr_Value_R (Right);
1405 else
1406 Right_Real := UR_From_Uint (Expr_Value (Right));
1407 end if;
1408
1409 if Nkind (N) = N_Op_Add then
1410 Result := Left_Real + Right_Real;
1411
1412 elsif Nkind (N) = N_Op_Subtract then
1413 Result := Left_Real - Right_Real;
1414
1415 elsif Nkind (N) = N_Op_Multiply then
1416 Result := Left_Real * Right_Real;
1417
1418 else pragma Assert (Nkind (N) = N_Op_Divide);
1419 if UR_Is_Zero (Right_Real) then
1420 Apply_Compile_Time_Constraint_Error
07fc65c4 1421 (N, "division by zero", CE_Divide_By_Zero);
996ae0b0
RK
1422 return;
1423 end if;
1424
1425 Result := Left_Real / Right_Real;
1426 end if;
1427
fbf5a39b 1428 Fold_Ureal (N, Result, Stat);
996ae0b0
RK
1429 end;
1430 end if;
996ae0b0
RK
1431 end Eval_Arithmetic_Op;
1432
1433 ----------------------------
1434 -- Eval_Character_Literal --
1435 ----------------------------
1436
1437 -- Nothing to be done!
1438
1439 procedure Eval_Character_Literal (N : Node_Id) is
07fc65c4 1440 pragma Warnings (Off, N);
996ae0b0
RK
1441 begin
1442 null;
1443 end Eval_Character_Literal;
1444
c01a9391
AC
1445 ---------------
1446 -- Eval_Call --
1447 ---------------
1448
1449 -- Static function calls are either calls to predefined operators
1450 -- with static arguments, or calls to functions that rename a literal.
1451 -- Only the latter case is handled here, predefined operators are
1452 -- constant-folded elsewhere.
29797f34 1453
c01a9391
AC
1454 -- If the function is itself inherited (see 7423-001) the literal of
1455 -- the parent type must be explicitly converted to the return type
1456 -- of the function.
1457
1458 procedure Eval_Call (N : Node_Id) is
1459 Loc : constant Source_Ptr := Sloc (N);
1460 Typ : constant Entity_Id := Etype (N);
1461 Lit : Entity_Id;
1462
1463 begin
1464 if Nkind (N) = N_Function_Call
1465 and then No (Parameter_Associations (N))
1466 and then Is_Entity_Name (Name (N))
1467 and then Present (Alias (Entity (Name (N))))
1468 and then Is_Enumeration_Type (Base_Type (Typ))
1469 then
1470 Lit := Alias (Entity (Name (N)));
c01a9391
AC
1471 while Present (Alias (Lit)) loop
1472 Lit := Alias (Lit);
1473 end loop;
1474
1475 if Ekind (Lit) = E_Enumeration_Literal then
1476 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
1477 Rewrite
1478 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
1479 else
1480 Rewrite (N, New_Occurrence_Of (Lit, Loc));
1481 end if;
1482
1483 Resolve (N, Typ);
1484 end if;
1485 end if;
1486 end Eval_Call;
1487
996ae0b0
RK
1488 ------------------------
1489 -- Eval_Concatenation --
1490 ------------------------
1491
1492 -- Concatenation is a static function, so the result is static if
1493 -- both operands are static (RM 4.9(7), 4.9(21)).
1494
1495 procedure Eval_Concatenation (N : Node_Id) is
f91b40db
GB
1496 Left : constant Node_Id := Left_Opnd (N);
1497 Right : constant Node_Id := Right_Opnd (N);
1498 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
996ae0b0
RK
1499 Stat : Boolean;
1500 Fold : Boolean;
996ae0b0
RK
1501
1502 begin
1503 -- Concatenation is never static in Ada 83, so if Ada 83
1504 -- check operand non-static context
1505
0ab80019 1506 if Ada_Version = Ada_83
996ae0b0
RK
1507 and then Comes_From_Source (N)
1508 then
1509 Check_Non_Static_Context (Left);
1510 Check_Non_Static_Context (Right);
1511 return;
1512 end if;
1513
1514 -- If not foldable we are done. In principle concatenation that yields
1515 -- any string type is static (i.e. an array type of character types).
1516 -- However, character types can include enumeration literals, and
1517 -- concatenation in that case cannot be described by a literal, so we
1518 -- only consider the operation static if the result is an array of
1519 -- (a descendant of) a predefined character type.
1520
1521 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1522
45fc7ddb 1523 if Is_Standard_Character_Type (C_Typ)
996ae0b0
RK
1524 and then Fold
1525 then
1526 null;
1527 else
1528 Set_Is_Static_Expression (N, False);
1529 return;
1530 end if;
1531
82c80734 1532 -- Compile time string concatenation
996ae0b0
RK
1533
1534 -- ??? Note that operands that are aggregates can be marked as
1535 -- static, so we should attempt at a later stage to fold
1536 -- concatenations with such aggregates.
1537
1538 declare
b54ddf5a
BD
1539 Left_Str : constant Node_Id := Get_String_Val (Left);
1540 Left_Len : Nat;
1541 Right_Str : constant Node_Id := Get_String_Val (Right);
1542 Folded_Val : String_Id;
996ae0b0
RK
1543
1544 begin
1545 -- Establish new string literal, and store left operand. We make
1546 -- sure to use the special Start_String that takes an operand if
1547 -- the left operand is a string literal. Since this is optimized
1548 -- in the case where that is the most recently created string
1549 -- literal, we ensure efficient time/space behavior for the
1550 -- case of a concatenation of a series of string literals.
1551
1552 if Nkind (Left_Str) = N_String_Literal then
f91b40db 1553 Left_Len := String_Length (Strval (Left_Str));
b54ddf5a
BD
1554
1555 -- If the left operand is the empty string, and the right operand
1556 -- is a string literal (the case of "" & "..."), the result is the
1557 -- value of the right operand. This optimization is important when
1558 -- Is_Folded_In_Parser, to avoid copying an enormous right
1559 -- operand.
1560
1561 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
1562 Folded_Val := Strval (Right_Str);
1563 else
1564 Start_String (Strval (Left_Str));
1565 end if;
1566
996ae0b0
RK
1567 else
1568 Start_String;
82c80734 1569 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
f91b40db 1570 Left_Len := 1;
996ae0b0
RK
1571 end if;
1572
b54ddf5a
BD
1573 -- Now append the characters of the right operand, unless we
1574 -- optimized the "" & "..." case above.
996ae0b0
RK
1575
1576 if Nkind (Right_Str) = N_String_Literal then
b54ddf5a
BD
1577 if Left_Len /= 0 then
1578 Store_String_Chars (Strval (Right_Str));
1579 Folded_Val := End_String;
1580 end if;
996ae0b0 1581 else
82c80734 1582 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
b54ddf5a 1583 Folded_Val := End_String;
996ae0b0
RK
1584 end if;
1585
1586 Set_Is_Static_Expression (N, Stat);
1587
1588 if Stat then
f91b40db
GB
1589
1590 -- If left operand is the empty string, the result is the
1591 -- right operand, including its bounds if anomalous.
1592
1593 if Left_Len = 0
1594 and then Is_Array_Type (Etype (Right))
1595 and then Etype (Right) /= Any_String
1596 then
1597 Set_Etype (N, Etype (Right));
1598 end if;
1599
b54ddf5a 1600 Fold_Str (N, Folded_Val, Static => True);
996ae0b0
RK
1601 end if;
1602 end;
1603 end Eval_Concatenation;
1604
1605 ---------------------------------
1606 -- Eval_Conditional_Expression --
1607 ---------------------------------
1608
1609 -- This GNAT internal construct can never be statically folded, so the
1610 -- only required processing is to do the check for non-static context
1611 -- for the two expression operands.
1612
1613 procedure Eval_Conditional_Expression (N : Node_Id) is
1614 Condition : constant Node_Id := First (Expressions (N));
1615 Then_Expr : constant Node_Id := Next (Condition);
1616 Else_Expr : constant Node_Id := Next (Then_Expr);
1617
1618 begin
1619 Check_Non_Static_Context (Then_Expr);
1620 Check_Non_Static_Context (Else_Expr);
1621 end Eval_Conditional_Expression;
1622
1623 ----------------------
1624 -- Eval_Entity_Name --
1625 ----------------------
1626
1627 -- This procedure is used for identifiers and expanded names other than
1628 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1629 -- static if they denote a static constant (RM 4.9(6)) or if the name
1630 -- denotes an enumeration literal (RM 4.9(22)).
1631
1632 procedure Eval_Entity_Name (N : Node_Id) is
1633 Def_Id : constant Entity_Id := Entity (N);
1634 Val : Node_Id;
1635
1636 begin
1637 -- Enumeration literals are always considered to be constants
1638 -- and cannot raise constraint error (RM 4.9(22)).
1639
1640 if Ekind (Def_Id) = E_Enumeration_Literal then
1641 Set_Is_Static_Expression (N);
1642 return;
1643
1644 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1645 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1646 -- it does not violate 10.2.1(8) here, since this is not a variable.
1647
1648 elsif Ekind (Def_Id) = E_Constant then
1649
1650 -- Deferred constants must always be treated as nonstatic
1651 -- outside the scope of their full view.
1652
1653 if Present (Full_View (Def_Id))
1654 and then not In_Open_Scopes (Scope (Def_Id))
1655 then
1656 Val := Empty;
1657 else
1658 Val := Constant_Value (Def_Id);
1659 end if;
1660
1661 if Present (Val) then
1662 Set_Is_Static_Expression
1663 (N, Is_Static_Expression (Val)
1664 and then Is_Static_Subtype (Etype (Def_Id)));
1665 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1666
1667 if not Is_Static_Expression (N)
1668 and then not Is_Generic_Type (Etype (N))
1669 then
1670 Validate_Static_Object_Name (N);
1671 end if;
1672
1673 return;
1674 end if;
1675 end if;
1676
82c80734 1677 -- Fall through if the name is not static
996ae0b0
RK
1678
1679 Validate_Static_Object_Name (N);
1680 end Eval_Entity_Name;
1681
1682 ----------------------------
1683 -- Eval_Indexed_Component --
1684 ----------------------------
1685
8cbb664e
MG
1686 -- Indexed components are never static, so we need to perform the check
1687 -- for non-static context on the index values. Then, we check if the
1688 -- value can be obtained at compile time, even though it is non-static.
996ae0b0
RK
1689
1690 procedure Eval_Indexed_Component (N : Node_Id) is
1691 Expr : Node_Id;
1692
1693 begin
fbf5a39b
AC
1694 -- Check for non-static context on index values
1695
996ae0b0
RK
1696 Expr := First (Expressions (N));
1697 while Present (Expr) loop
1698 Check_Non_Static_Context (Expr);
1699 Next (Expr);
1700 end loop;
1701
fbf5a39b
AC
1702 -- If the indexed component appears in an object renaming declaration
1703 -- then we do not want to try to evaluate it, since in this case we
1704 -- need the identity of the array element.
1705
1706 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
1707 return;
1708
1709 -- Similarly if the indexed component appears as the prefix of an
1710 -- attribute we don't want to evaluate it, because at least for
1711 -- some cases of attributes we need the identify (e.g. Access, Size)
1712
1713 elsif Nkind (Parent (N)) = N_Attribute_Reference then
1714 return;
1715 end if;
1716
1717 -- Note: there are other cases, such as the left side of an assignment,
1718 -- or an OUT parameter for a call, where the replacement results in the
1719 -- illegal use of a constant, But these cases are illegal in the first
1720 -- place, so the replacement, though silly, is harmless.
1721
1722 -- Now see if this is a constant array reference
8cbb664e
MG
1723
1724 if List_Length (Expressions (N)) = 1
1725 and then Is_Entity_Name (Prefix (N))
1726 and then Ekind (Entity (Prefix (N))) = E_Constant
1727 and then Present (Constant_Value (Entity (Prefix (N))))
1728 then
1729 declare
1730 Loc : constant Source_Ptr := Sloc (N);
1731 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
1732 Sub : constant Node_Id := First (Expressions (N));
1733
1734 Atyp : Entity_Id;
1735 -- Type of array
1736
1737 Lin : Nat;
1738 -- Linear one's origin subscript value for array reference
1739
1740 Lbd : Node_Id;
1741 -- Lower bound of the first array index
1742
1743 Elm : Node_Id;
1744 -- Value from constant array
1745
1746 begin
1747 Atyp := Etype (Arr);
1748
1749 if Is_Access_Type (Atyp) then
1750 Atyp := Designated_Type (Atyp);
1751 end if;
1752
1753 -- If we have an array type (we should have but perhaps there
1754 -- are error cases where this is not the case), then see if we
1755 -- can do a constant evaluation of the array reference.
1756
1757 if Is_Array_Type (Atyp) then
1758 if Ekind (Atyp) = E_String_Literal_Subtype then
1759 Lbd := String_Literal_Low_Bound (Atyp);
1760 else
1761 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
1762 end if;
1763
1764 if Compile_Time_Known_Value (Sub)
1765 and then Nkind (Arr) = N_Aggregate
1766 and then Compile_Time_Known_Value (Lbd)
1767 and then Is_Discrete_Type (Component_Type (Atyp))
1768 then
1769 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
1770
1771 if List_Length (Expressions (Arr)) >= Lin then
1772 Elm := Pick (Expressions (Arr), Lin);
1773
1774 -- If the resulting expression is compile time known,
1775 -- then we can rewrite the indexed component with this
1776 -- value, being sure to mark the result as non-static.
1777 -- We also reset the Sloc, in case this generates an
1778 -- error later on (e.g. 136'Access).
1779
1780 if Compile_Time_Known_Value (Elm) then
1781 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
1782 Set_Is_Static_Expression (N, False);
1783 Set_Sloc (N, Loc);
1784 end if;
1785 end if;
1786 end if;
1787 end if;
1788 end;
1789 end if;
996ae0b0
RK
1790 end Eval_Indexed_Component;
1791
1792 --------------------------
1793 -- Eval_Integer_Literal --
1794 --------------------------
1795
1796 -- Numeric literals are static (RM 4.9(1)), and have already been marked
1797 -- as static by the analyzer. The reason we did it that early is to allow
1798 -- the possibility of turning off the Is_Static_Expression flag after
1799 -- analysis, but before resolution, when integer literals are generated
1800 -- in the expander that do not correspond to static expressions.
1801
1802 procedure Eval_Integer_Literal (N : Node_Id) is
1803 T : constant Entity_Id := Etype (N);
1804
5d09245e
AC
1805 function In_Any_Integer_Context return Boolean;
1806 -- If the literal is resolved with a specific type in a context
1807 -- where the expected type is Any_Integer, there are no range checks
1808 -- on the literal. By the time the literal is evaluated, it carries
1809 -- the type imposed by the enclosing expression, and we must recover
1810 -- the context to determine that Any_Integer is meant.
1811
1812 ----------------------------
1813 -- To_Any_Integer_Context --
1814 ----------------------------
1815
1816 function In_Any_Integer_Context return Boolean is
1817 Par : constant Node_Id := Parent (N);
1818 K : constant Node_Kind := Nkind (Par);
1819
1820 begin
1821 -- Any_Integer also appears in digits specifications for real types,
1822 -- but those have bounds smaller that those of any integer base
1823 -- type, so we can safely ignore these cases.
1824
1825 return K = N_Number_Declaration
1826 or else K = N_Attribute_Reference
1827 or else K = N_Attribute_Definition_Clause
1828 or else K = N_Modular_Type_Definition
1829 or else K = N_Signed_Integer_Type_Definition;
1830 end In_Any_Integer_Context;
1831
1832 -- Start of processing for Eval_Integer_Literal
1833
996ae0b0 1834 begin
5d09245e 1835
996ae0b0
RK
1836 -- If the literal appears in a non-expression context, then it is
1837 -- certainly appearing in a non-static context, so check it. This
1838 -- is actually a redundant check, since Check_Non_Static_Context
1839 -- would check it, but it seems worth while avoiding the call.
1840
5d09245e
AC
1841 if Nkind (Parent (N)) not in N_Subexpr
1842 and then not In_Any_Integer_Context
1843 then
996ae0b0
RK
1844 Check_Non_Static_Context (N);
1845 end if;
1846
1847 -- Modular integer literals must be in their base range
1848
1849 if Is_Modular_Integer_Type (T)
c800f862 1850 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
996ae0b0
RK
1851 then
1852 Out_Of_Range (N);
1853 end if;
1854 end Eval_Integer_Literal;
1855
1856 ---------------------
1857 -- Eval_Logical_Op --
1858 ---------------------
1859
1860 -- Logical operations are static functions, so the result is potentially
1861 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1862
1863 procedure Eval_Logical_Op (N : Node_Id) is
1864 Left : constant Node_Id := Left_Opnd (N);
1865 Right : constant Node_Id := Right_Opnd (N);
1866 Stat : Boolean;
1867 Fold : Boolean;
1868
1869 begin
1870 -- If not foldable we are done
1871
1872 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1873
1874 if not Fold then
1875 return;
1876 end if;
1877
1878 -- Compile time evaluation of logical operation
1879
1880 declare
1881 Left_Int : constant Uint := Expr_Value (Left);
1882 Right_Int : constant Uint := Expr_Value (Right);
1883
1884 begin
1885 if Is_Modular_Integer_Type (Etype (N)) then
1886 declare
1887 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1888 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1889
1890 begin
1891 To_Bits (Left_Int, Left_Bits);
1892 To_Bits (Right_Int, Right_Bits);
1893
1894 -- Note: should really be able to use array ops instead of
1895 -- these loops, but they weren't working at the time ???
1896
1897 if Nkind (N) = N_Op_And then
1898 for J in Left_Bits'Range loop
1899 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
1900 end loop;
1901
1902 elsif Nkind (N) = N_Op_Or then
1903 for J in Left_Bits'Range loop
1904 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
1905 end loop;
1906
1907 else
1908 pragma Assert (Nkind (N) = N_Op_Xor);
1909
1910 for J in Left_Bits'Range loop
1911 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
1912 end loop;
1913 end if;
1914
fbf5a39b 1915 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
996ae0b0
RK
1916 end;
1917
1918 else
1919 pragma Assert (Is_Boolean_Type (Etype (N)));
1920
1921 if Nkind (N) = N_Op_And then
1922 Fold_Uint (N,
fbf5a39b 1923 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
996ae0b0
RK
1924
1925 elsif Nkind (N) = N_Op_Or then
1926 Fold_Uint (N,
fbf5a39b 1927 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
996ae0b0
RK
1928
1929 else
1930 pragma Assert (Nkind (N) = N_Op_Xor);
1931 Fold_Uint (N,
fbf5a39b 1932 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
996ae0b0
RK
1933 end if;
1934 end if;
996ae0b0
RK
1935 end;
1936 end Eval_Logical_Op;
1937
1938 ------------------------
1939 -- Eval_Membership_Op --
1940 ------------------------
1941
1942 -- A membership test is potentially static if the expression is static,
1943 -- and the range is a potentially static range, or is a subtype mark
1944 -- denoting a static subtype (RM 4.9(12)).
1945
1946 procedure Eval_Membership_Op (N : Node_Id) is
1947 Left : constant Node_Id := Left_Opnd (N);
1948 Right : constant Node_Id := Right_Opnd (N);
1949 Def_Id : Entity_Id;
1950 Lo : Node_Id;
1951 Hi : Node_Id;
1952 Result : Boolean;
1953 Stat : Boolean;
1954 Fold : Boolean;
1955
1956 begin
1957 -- Ignore if error in either operand, except to make sure that
1958 -- Any_Type is properly propagated to avoid junk cascaded errors.
1959
1960 if Etype (Left) = Any_Type
1961 or else Etype (Right) = Any_Type
1962 then
1963 Set_Etype (N, Any_Type);
1964 return;
1965 end if;
1966
1967 -- Case of right operand is a subtype name
1968
1969 if Is_Entity_Name (Right) then
1970 Def_Id := Entity (Right);
1971
1972 if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
1973 and then Is_OK_Static_Subtype (Def_Id)
1974 then
1975 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
1976
1977 if not Fold or else not Stat then
1978 return;
1979 end if;
1980 else
1981 Check_Non_Static_Context (Left);
1982 return;
1983 end if;
1984
1985 -- For string membership tests we will check the length
1986 -- further below.
1987
1988 if not Is_String_Type (Def_Id) then
1989 Lo := Type_Low_Bound (Def_Id);
1990 Hi := Type_High_Bound (Def_Id);
1991
1992 else
1993 Lo := Empty;
1994 Hi := Empty;
1995 end if;
1996
1997 -- Case of right operand is a range
1998
1999 else
2000 if Is_Static_Range (Right) then
2001 Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2002
2003 if not Fold or else not Stat then
2004 return;
2005
2006 -- If one bound of range raises CE, then don't try to fold
2007
2008 elsif not Is_OK_Static_Range (Right) then
2009 Check_Non_Static_Context (Left);
2010 return;
2011 end if;
2012
2013 else
2014 Check_Non_Static_Context (Left);
2015 return;
2016 end if;
2017
2018 -- Here we know range is an OK static range
2019
2020 Lo := Low_Bound (Right);
2021 Hi := High_Bound (Right);
2022 end if;
2023
2024 -- For strings we check that the length of the string expression is
2025 -- compatible with the string subtype if the subtype is constrained,
2026 -- or if unconstrained then the test is always true.
2027
2028 if Is_String_Type (Etype (Right)) then
2029 if not Is_Constrained (Etype (Right)) then
2030 Result := True;
2031
2032 else
2033 declare
2034 Typlen : constant Uint := String_Type_Len (Etype (Right));
2035 Strlen : constant Uint :=
2036 UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
2037 begin
2038 Result := (Typlen = Strlen);
2039 end;
2040 end if;
2041
2042 -- Fold the membership test. We know we have a static range and Lo
2043 -- and Hi are set to the expressions for the end points of this range.
2044
2045 elsif Is_Real_Type (Etype (Right)) then
2046 declare
2047 Leftval : constant Ureal := Expr_Value_R (Left);
2048
2049 begin
2050 Result := Expr_Value_R (Lo) <= Leftval
2051 and then Leftval <= Expr_Value_R (Hi);
2052 end;
2053
2054 else
2055 declare
2056 Leftval : constant Uint := Expr_Value (Left);
2057
2058 begin
2059 Result := Expr_Value (Lo) <= Leftval
2060 and then Leftval <= Expr_Value (Hi);
2061 end;
2062 end if;
2063
2064 if Nkind (N) = N_Not_In then
2065 Result := not Result;
2066 end if;
2067
fbf5a39b 2068 Fold_Uint (N, Test (Result), True);
996ae0b0 2069 Warn_On_Known_Condition (N);
996ae0b0
RK
2070 end Eval_Membership_Op;
2071
2072 ------------------------
2073 -- Eval_Named_Integer --
2074 ------------------------
2075
2076 procedure Eval_Named_Integer (N : Node_Id) is
2077 begin
2078 Fold_Uint (N,
fbf5a39b 2079 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
996ae0b0
RK
2080 end Eval_Named_Integer;
2081
2082 ---------------------
2083 -- Eval_Named_Real --
2084 ---------------------
2085
2086 procedure Eval_Named_Real (N : Node_Id) is
2087 begin
2088 Fold_Ureal (N,
fbf5a39b 2089 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
996ae0b0
RK
2090 end Eval_Named_Real;
2091
2092 -------------------
2093 -- Eval_Op_Expon --
2094 -------------------
2095
2096 -- Exponentiation is a static functions, so the result is potentially
2097 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2098
2099 procedure Eval_Op_Expon (N : Node_Id) is
2100 Left : constant Node_Id := Left_Opnd (N);
2101 Right : constant Node_Id := Right_Opnd (N);
2102 Stat : Boolean;
2103 Fold : Boolean;
2104
2105 begin
2106 -- If not foldable we are done
2107
2108 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2109
2110 if not Fold then
2111 return;
2112 end if;
2113
2114 -- Fold exponentiation operation
2115
2116 declare
2117 Right_Int : constant Uint := Expr_Value (Right);
2118
2119 begin
2120 -- Integer case
2121
2122 if Is_Integer_Type (Etype (Left)) then
2123 declare
2124 Left_Int : constant Uint := Expr_Value (Left);
2125 Result : Uint;
2126
2127 begin
2128 -- Exponentiation of an integer raises the exception
2129 -- Constraint_Error for a negative exponent (RM 4.5.6)
2130
2131 if Right_Int < 0 then
2132 Apply_Compile_Time_Constraint_Error
fbf5a39b
AC
2133 (N, "integer exponent negative",
2134 CE_Range_Check_Failed,
2135 Warn => not Stat);
996ae0b0
RK
2136 return;
2137
2138 else
2139 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2140 Result := Left_Int ** Right_Int;
2141 else
2142 Result := Left_Int;
2143 end if;
2144
2145 if Is_Modular_Integer_Type (Etype (N)) then
2146 Result := Result mod Modulus (Etype (N));
2147 end if;
2148
fbf5a39b 2149 Fold_Uint (N, Result, Stat);
996ae0b0
RK
2150 end if;
2151 end;
2152
2153 -- Real case
2154
2155 else
2156 declare
2157 Left_Real : constant Ureal := Expr_Value_R (Left);
2158
2159 begin
2160 -- Cannot have a zero base with a negative exponent
2161
2162 if UR_Is_Zero (Left_Real) then
2163
2164 if Right_Int < 0 then
2165 Apply_Compile_Time_Constraint_Error
fbf5a39b
AC
2166 (N, "zero ** negative integer",
2167 CE_Range_Check_Failed,
2168 Warn => not Stat);
996ae0b0
RK
2169 return;
2170 else
fbf5a39b 2171 Fold_Ureal (N, Ureal_0, Stat);
996ae0b0
RK
2172 end if;
2173
2174 else
fbf5a39b 2175 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
996ae0b0
RK
2176 end if;
2177 end;
2178 end if;
996ae0b0
RK
2179 end;
2180 end Eval_Op_Expon;
2181
2182 -----------------
2183 -- Eval_Op_Not --
2184 -----------------
2185
2186 -- The not operation is a static functions, so the result is potentially
2187 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2188
2189 procedure Eval_Op_Not (N : Node_Id) is
2190 Right : constant Node_Id := Right_Opnd (N);
2191 Stat : Boolean;
2192 Fold : Boolean;
2193
2194 begin
2195 -- If not foldable we are done
2196
2197 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2198
2199 if not Fold then
2200 return;
2201 end if;
2202
2203 -- Fold not operation
2204
2205 declare
2206 Rint : constant Uint := Expr_Value (Right);
2207 Typ : constant Entity_Id := Etype (N);
2208
2209 begin
2210 -- Negation is equivalent to subtracting from the modulus minus
2211 -- one. For a binary modulus this is equivalent to the ones-
2212 -- component of the original value. For non-binary modulus this
2213 -- is an arbitrary but consistent definition.
2214
2215 if Is_Modular_Integer_Type (Typ) then
fbf5a39b 2216 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
996ae0b0
RK
2217
2218 else
2219 pragma Assert (Is_Boolean_Type (Typ));
fbf5a39b 2220 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
996ae0b0
RK
2221 end if;
2222
2223 Set_Is_Static_Expression (N, Stat);
2224 end;
2225 end Eval_Op_Not;
2226
2227 -------------------------------
2228 -- Eval_Qualified_Expression --
2229 -------------------------------
2230
2231 -- A qualified expression is potentially static if its subtype mark denotes
2232 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2233
2234 procedure Eval_Qualified_Expression (N : Node_Id) is
2235 Operand : constant Node_Id := Expression (N);
2236 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2237
07fc65c4
GB
2238 Stat : Boolean;
2239 Fold : Boolean;
2240 Hex : Boolean;
996ae0b0
RK
2241
2242 begin
2243 -- Can only fold if target is string or scalar and subtype is static
2244 -- Also, do not fold if our parent is an allocator (this is because
2245 -- the qualified expression is really part of the syntactic structure
2246 -- of an allocator, and we do not want to end up with something that
2247 -- corresponds to "new 1" where the 1 is the result of folding a
2248 -- qualified expression).
2249
2250 if not Is_Static_Subtype (Target_Type)
2251 or else Nkind (Parent (N)) = N_Allocator
2252 then
2253 Check_Non_Static_Context (Operand);
af152989
AC
2254
2255 -- If operand is known to raise constraint_error, set the
2256 -- flag on the expression so it does not get optimized away.
2257
2258 if Nkind (Operand) = N_Raise_Constraint_Error then
2259 Set_Raises_Constraint_Error (N);
2260 end if;
7324bf49 2261
996ae0b0
RK
2262 return;
2263 end if;
2264
2265 -- If not foldable we are done
2266
2267 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2268
2269 if not Fold then
2270 return;
2271
2272 -- Don't try fold if target type has constraint error bounds
2273
2274 elsif not Is_OK_Static_Subtype (Target_Type) then
2275 Set_Raises_Constraint_Error (N);
2276 return;
2277 end if;
2278
07fc65c4
GB
2279 -- Here we will fold, save Print_In_Hex indication
2280
2281 Hex := Nkind (Operand) = N_Integer_Literal
2282 and then Print_In_Hex (Operand);
2283
996ae0b0
RK
2284 -- Fold the result of qualification
2285
2286 if Is_Discrete_Type (Target_Type) then
fbf5a39b 2287 Fold_Uint (N, Expr_Value (Operand), Stat);
996ae0b0 2288
07fc65c4
GB
2289 -- Preserve Print_In_Hex indication
2290
2291 if Hex and then Nkind (N) = N_Integer_Literal then
2292 Set_Print_In_Hex (N);
2293 end if;
2294
996ae0b0 2295 elsif Is_Real_Type (Target_Type) then
fbf5a39b 2296 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
996ae0b0
RK
2297
2298 else
fbf5a39b 2299 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
996ae0b0
RK
2300
2301 if not Stat then
2302 Set_Is_Static_Expression (N, False);
2303 else
2304 Check_String_Literal_Length (N, Target_Type);
2305 end if;
2306
2307 return;
2308 end if;
2309
fbf5a39b
AC
2310 -- The expression may be foldable but not static
2311
2312 Set_Is_Static_Expression (N, Stat);
2313
c800f862 2314 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
996ae0b0
RK
2315 Out_Of_Range (N);
2316 end if;
996ae0b0
RK
2317 end Eval_Qualified_Expression;
2318
2319 -----------------------
2320 -- Eval_Real_Literal --
2321 -----------------------
2322
2323 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2324 -- as static by the analyzer. The reason we did it that early is to allow
2325 -- the possibility of turning off the Is_Static_Expression flag after
2326 -- analysis, but before resolution, when integer literals are generated
2327 -- in the expander that do not correspond to static expressions.
2328
2329 procedure Eval_Real_Literal (N : Node_Id) is
a1980be8
GB
2330 PK : constant Node_Kind := Nkind (Parent (N));
2331
996ae0b0 2332 begin
a1980be8
GB
2333 -- If the literal appears in a non-expression context
2334 -- and not as part of a number declaration, then it is
2335 -- appearing in a non-static context, so check it.
996ae0b0 2336
a1980be8 2337 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
996ae0b0
RK
2338 Check_Non_Static_Context (N);
2339 end if;
996ae0b0
RK
2340 end Eval_Real_Literal;
2341
2342 ------------------------
2343 -- Eval_Relational_Op --
2344 ------------------------
2345
2346 -- Relational operations are static functions, so the result is static
2347 -- if both operands are static (RM 4.9(7), 4.9(20)).
2348
2349 procedure Eval_Relational_Op (N : Node_Id) is
2350 Left : constant Node_Id := Left_Opnd (N);
2351 Right : constant Node_Id := Right_Opnd (N);
2352 Typ : constant Entity_Id := Etype (Left);
2353 Result : Boolean;
2354 Stat : Boolean;
2355 Fold : Boolean;
2356
2357 begin
45fc7ddb
HK
2358 -- One special case to deal with first. If we can tell that the result
2359 -- will be false because the lengths of one or more index subtypes are
2360 -- compile time known and different, then we can replace the entire
2361 -- result by False. We only do this for one dimensional arrays, because
2362 -- the case of multi-dimensional arrays is rare and too much trouble! If
2363 -- one of the operands is an illegal aggregate, its type might still be
2364 -- an arbitrary composite type, so nothing to do.
996ae0b0
RK
2365
2366 if Is_Array_Type (Typ)
13f34a3f 2367 and then Typ /= Any_Composite
996ae0b0 2368 and then Number_Dimensions (Typ) = 1
13f34a3f 2369 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
996ae0b0
RK
2370 then
2371 if Raises_Constraint_Error (Left)
2372 or else Raises_Constraint_Error (Right)
2373 then
2374 return;
2375 end if;
2376
45fc7ddb
HK
2377 -- OK, we have the case where we may be able to do this fold
2378
2379 Length_Mismatch : declare
996ae0b0 2380 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
13f34a3f
RD
2381 -- If Op is an expression for a constrained array with a known
2382 -- at compile time length, then Len is set to this (non-negative
2383 -- length). Otherwise Len is set to minus 1.
996ae0b0 2384
fbf5a39b
AC
2385 -----------------------
2386 -- Get_Static_Length --
2387 -----------------------
2388
996ae0b0
RK
2389 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2390 T : Entity_Id;
2391
2392 begin
45fc7ddb
HK
2393 -- First easy case string literal
2394
996ae0b0
RK
2395 if Nkind (Op) = N_String_Literal then
2396 Len := UI_From_Int (String_Length (Strval (Op)));
45fc7ddb
HK
2397 return;
2398 end if;
2399
2400 -- Second easy case, not constrained subtype, so no length
996ae0b0 2401
45fc7ddb 2402 if not Is_Constrained (Etype (Op)) then
996ae0b0 2403 Len := Uint_Minus_1;
45fc7ddb
HK
2404 return;
2405 end if;
996ae0b0 2406
45fc7ddb
HK
2407 -- General case
2408
2409 T := Etype (First_Index (Etype (Op)));
2410
2411 -- The simple case, both bounds are known at compile time
2412
2413 if Is_Discrete_Type (T)
2414 and then
2415 Compile_Time_Known_Value (Type_Low_Bound (T))
2416 and then
2417 Compile_Time_Known_Value (Type_High_Bound (T))
2418 then
2419 Len := UI_Max (Uint_0,
2420 Expr_Value (Type_High_Bound (T)) -
2421 Expr_Value (Type_Low_Bound (T)) + 1);
2422 return;
2423 end if;
2424
2425 -- A more complex case, where the bounds are of the form
2426 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2427 -- either A'First or A'Last (with A an entity name), or X is an
2428 -- entity name, and the two X's are the same and K1 and K2 are
2429 -- known at compile time, in this case, the length can also be
2430 -- computed at compile time, even though the bounds are not
2431 -- known. A common case of this is e.g. (X'First..X'First+5).
2432
2433 Extract_Length : declare
2434 procedure Decompose_Expr
2435 (Expr : Node_Id;
2436 Ent : out Entity_Id;
2437 Kind : out Character;
2438 Cons : out Uint);
2439 -- Given an expression, see if is of the form above,
2440 -- X [+/- K]. If so Ent is set to the entity in X,
2441 -- Kind is 'F','L','E' for 'First/'Last/simple entity,
2442 -- and Cons is the value of K. If the expression is
2443 -- not of the required form, Ent is set to Empty.
2444
2445 --------------------
2446 -- Decompose_Expr --
2447 --------------------
2448
2449 procedure Decompose_Expr
2450 (Expr : Node_Id;
2451 Ent : out Entity_Id;
2452 Kind : out Character;
2453 Cons : out Uint)
2454 is
2455 Exp : Node_Id;
2456
2457 begin
2458 if Nkind (Expr) = N_Op_Add
2459 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2460 then
2461 Exp := Left_Opnd (Expr);
2462 Cons := Expr_Value (Right_Opnd (Expr));
2463
2464 elsif Nkind (Expr) = N_Op_Subtract
2465 and then Compile_Time_Known_Value (Right_Opnd (Expr))
2466 then
2467 Exp := Left_Opnd (Expr);
2468 Cons := -Expr_Value (Right_Opnd (Expr));
996ae0b0 2469
45fc7ddb
HK
2470 else
2471 Exp := Expr;
2472 Cons := Uint_0;
2473 end if;
2474
2475 -- At this stage Exp is set to the potential X
2476
2477 if Nkind (Exp) = N_Attribute_Reference then
2478 if Attribute_Name (Exp) = Name_First then
2479 Kind := 'F';
2480 elsif Attribute_Name (Exp) = Name_Last then
2481 Kind := 'L';
2482 else
2483 Ent := Empty;
2484 return;
2485 end if;
2486
2487 Exp := Prefix (Exp);
2488
2489 else
2490 Kind := 'E';
2491 end if;
2492
2493 if Is_Entity_Name (Exp)
2494 and then Present (Entity (Exp))
2495 then
2496 Ent := Entity (Exp);
2497 else
2498 Ent := Empty;
2499 end if;
2500 end Decompose_Expr;
2501
2502 -- Local Variables
2503
2504 Ent1, Ent2 : Entity_Id;
2505 Kind1, Kind2 : Character;
2506 Cons1, Cons2 : Uint;
2507
2508 -- Start of processing for Extract_Length
2509
2510 begin
2511 Decompose_Expr (Type_Low_Bound (T), Ent1, Kind1, Cons1);
2512 Decompose_Expr (Type_High_Bound (T), Ent2, Kind2, Cons2);
2513
2514 if Present (Ent1)
2515 and then Kind1 = Kind2
2516 and then Ent1 = Ent2
996ae0b0 2517 then
45fc7ddb 2518 Len := Cons2 - Cons1 + 1;
996ae0b0
RK
2519 else
2520 Len := Uint_Minus_1;
2521 end if;
45fc7ddb 2522 end Extract_Length;
996ae0b0
RK
2523 end Get_Static_Length;
2524
45fc7ddb
HK
2525 -- Local Variables
2526
996ae0b0
RK
2527 Len_L : Uint;
2528 Len_R : Uint;
2529
45fc7ddb
HK
2530 -- Start of processing for Length_Mismatch
2531
996ae0b0
RK
2532 begin
2533 Get_Static_Length (Left, Len_L);
2534 Get_Static_Length (Right, Len_R);
2535
2536 if Len_L /= Uint_Minus_1
2537 and then Len_R /= Uint_Minus_1
2538 and then Len_L /= Len_R
2539 then
fbf5a39b 2540 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
996ae0b0
RK
2541 Warn_On_Known_Condition (N);
2542 return;
2543 end if;
45fc7ddb
HK
2544 end Length_Mismatch;
2545 end if;
6eaf4095 2546
7a3f77d2
AC
2547 -- Another special case: comparisons of access types, where one or both
2548 -- operands are known to be null, so the result can be determined.
6eaf4095 2549
45fc7ddb 2550 if Is_Access_Type (Typ) then
7a3f77d2
AC
2551 if Known_Null (Left) then
2552 if Known_Null (Right) then
2553 Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False);
2554 Warn_On_Known_Condition (N);
2555 return;
2556
2557 elsif Known_Non_Null (Right) then
2558 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2559 Warn_On_Known_Condition (N);
2560 return;
2561 end if;
2562
2563 elsif Known_Non_Null (Left) then
2564 if Known_Null (Right) then
2565 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2566 Warn_On_Known_Condition (N);
2567 return;
2568 end if;
2569 end if;
996ae0b0
RK
2570 end if;
2571
2572 -- Can only fold if type is scalar (don't fold string ops)
2573
2574 if not Is_Scalar_Type (Typ) then
2575 Check_Non_Static_Context (Left);
2576 Check_Non_Static_Context (Right);
2577 return;
2578 end if;
2579
2580 -- If not foldable we are done
2581
2582 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2583
2584 if not Fold then
2585 return;
2586 end if;
2587
2588 -- Integer and Enumeration (discrete) type cases
2589
2590 if Is_Discrete_Type (Typ) then
2591 declare
2592 Left_Int : constant Uint := Expr_Value (Left);
2593 Right_Int : constant Uint := Expr_Value (Right);
2594
2595 begin
2596 case Nkind (N) is
2597 when N_Op_Eq => Result := Left_Int = Right_Int;
2598 when N_Op_Ne => Result := Left_Int /= Right_Int;
2599 when N_Op_Lt => Result := Left_Int < Right_Int;
2600 when N_Op_Le => Result := Left_Int <= Right_Int;
2601 when N_Op_Gt => Result := Left_Int > Right_Int;
2602 when N_Op_Ge => Result := Left_Int >= Right_Int;
2603
2604 when others =>
2605 raise Program_Error;
2606 end case;
2607
fbf5a39b 2608 Fold_Uint (N, Test (Result), Stat);
996ae0b0
RK
2609 end;
2610
2611 -- Real type case
2612
2613 else
2614 pragma Assert (Is_Real_Type (Typ));
2615
2616 declare
2617 Left_Real : constant Ureal := Expr_Value_R (Left);
2618 Right_Real : constant Ureal := Expr_Value_R (Right);
2619
2620 begin
2621 case Nkind (N) is
2622 when N_Op_Eq => Result := (Left_Real = Right_Real);
2623 when N_Op_Ne => Result := (Left_Real /= Right_Real);
2624 when N_Op_Lt => Result := (Left_Real < Right_Real);
2625 when N_Op_Le => Result := (Left_Real <= Right_Real);
2626 when N_Op_Gt => Result := (Left_Real > Right_Real);
2627 when N_Op_Ge => Result := (Left_Real >= Right_Real);
2628
2629 when others =>
2630 raise Program_Error;
2631 end case;
2632
fbf5a39b 2633 Fold_Uint (N, Test (Result), Stat);
996ae0b0
RK
2634 end;
2635 end if;
2636
996ae0b0
RK
2637 Warn_On_Known_Condition (N);
2638 end Eval_Relational_Op;
2639
2640 ----------------
2641 -- Eval_Shift --
2642 ----------------
2643
2644 -- Shift operations are intrinsic operations that can never be static,
2645 -- so the only processing required is to perform the required check for
2646 -- a non static context for the two operands.
2647
2648 -- Actually we could do some compile time evaluation here some time ???
2649
2650 procedure Eval_Shift (N : Node_Id) is
2651 begin
2652 Check_Non_Static_Context (Left_Opnd (N));
2653 Check_Non_Static_Context (Right_Opnd (N));
2654 end Eval_Shift;
2655
2656 ------------------------
2657 -- Eval_Short_Circuit --
2658 ------------------------
2659
2660 -- A short circuit operation is potentially static if both operands
2661 -- are potentially static (RM 4.9 (13))
2662
2663 procedure Eval_Short_Circuit (N : Node_Id) is
2664 Kind : constant Node_Kind := Nkind (N);
2665 Left : constant Node_Id := Left_Opnd (N);
2666 Right : constant Node_Id := Right_Opnd (N);
2667 Left_Int : Uint;
2668 Rstat : constant Boolean :=
2669 Is_Static_Expression (Left)
2670 and then Is_Static_Expression (Right);
2671
2672 begin
2673 -- Short circuit operations are never static in Ada 83
2674
0ab80019 2675 if Ada_Version = Ada_83
996ae0b0
RK
2676 and then Comes_From_Source (N)
2677 then
2678 Check_Non_Static_Context (Left);
2679 Check_Non_Static_Context (Right);
2680 return;
2681 end if;
2682
2683 -- Now look at the operands, we can't quite use the normal call to
2684 -- Test_Expression_Is_Foldable here because short circuit operations
2685 -- are a special case, they can still be foldable, even if the right
2686 -- operand raises constraint error.
2687
2688 -- If either operand is Any_Type, just propagate to result and
2689 -- do not try to fold, this prevents cascaded errors.
2690
2691 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2692 Set_Etype (N, Any_Type);
2693 return;
2694
2695 -- If left operand raises constraint error, then replace node N with
2696 -- the raise constraint error node, and we are obviously not foldable.
2697 -- Is_Static_Expression is set from the two operands in the normal way,
2698 -- and we check the right operand if it is in a non-static context.
2699
2700 elsif Raises_Constraint_Error (Left) then
2701 if not Rstat then
2702 Check_Non_Static_Context (Right);
2703 end if;
2704
2705 Rewrite_In_Raise_CE (N, Left);
2706 Set_Is_Static_Expression (N, Rstat);
2707 return;
2708
2709 -- If the result is not static, then we won't in any case fold
2710
2711 elsif not Rstat then
2712 Check_Non_Static_Context (Left);
2713 Check_Non_Static_Context (Right);
2714 return;
2715 end if;
2716
2717 -- Here the result is static, note that, unlike the normal processing
2718 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
2719 -- the right operand raises constraint error, that's because it is not
2720 -- significant if the left operand is decisive.
2721
2722 Set_Is_Static_Expression (N);
2723
2724 -- It does not matter if the right operand raises constraint error if
2725 -- it will not be evaluated. So deal specially with the cases where
2726 -- the right operand is not evaluated. Note that we will fold these
2727 -- cases even if the right operand is non-static, which is fine, but
2728 -- of course in these cases the result is not potentially static.
2729
2730 Left_Int := Expr_Value (Left);
2731
2732 if (Kind = N_And_Then and then Is_False (Left_Int))
2733 or else (Kind = N_Or_Else and Is_True (Left_Int))
2734 then
fbf5a39b 2735 Fold_Uint (N, Left_Int, Rstat);
996ae0b0
RK
2736 return;
2737 end if;
2738
2739 -- If first operand not decisive, then it does matter if the right
2740 -- operand raises constraint error, since it will be evaluated, so
2741 -- we simply replace the node with the right operand. Note that this
2742 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
2743 -- (both are set to True in Right).
2744
2745 if Raises_Constraint_Error (Right) then
2746 Rewrite_In_Raise_CE (N, Right);
2747 Check_Non_Static_Context (Left);
2748 return;
2749 end if;
2750
2751 -- Otherwise the result depends on the right operand
2752
fbf5a39b 2753 Fold_Uint (N, Expr_Value (Right), Rstat);
996ae0b0 2754 return;
996ae0b0
RK
2755 end Eval_Short_Circuit;
2756
2757 ----------------
2758 -- Eval_Slice --
2759 ----------------
2760
2761 -- Slices can never be static, so the only processing required is to
2762 -- check for non-static context if an explicit range is given.
2763
2764 procedure Eval_Slice (N : Node_Id) is
2765 Drange : constant Node_Id := Discrete_Range (N);
996ae0b0
RK
2766 begin
2767 if Nkind (Drange) = N_Range then
2768 Check_Non_Static_Context (Low_Bound (Drange));
2769 Check_Non_Static_Context (High_Bound (Drange));
2770 end if;
cd2fb920
ES
2771
2772 -- A slice of the form A (subtype), when the subtype is the index of
2773 -- the type of A, is redundant, the slice can be replaced with A, and
2774 -- this is worth a warning.
2775
2776 if Is_Entity_Name (Prefix (N)) then
2777 declare
2778 E : constant Entity_Id := Entity (Prefix (N));
2779 T : constant Entity_Id := Etype (E);
2780 begin
2781 if Ekind (E) = E_Constant
2782 and then Is_Array_Type (T)
2783 and then Is_Entity_Name (Drange)
2784 then
2785 if Is_Entity_Name (Original_Node (First_Index (T)))
2786 and then Entity (Original_Node (First_Index (T)))
2787 = Entity (Drange)
2788 then
2789 if Warn_On_Redundant_Constructs then
2790 Error_Msg_N ("redundant slice denotes whole array?", N);
2791 end if;
2792
2793 -- The following might be a useful optimization ????
2794
2795 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
2796 end if;
2797 end if;
2798 end;
2799 end if;
996ae0b0
RK
2800 end Eval_Slice;
2801
2802 -------------------------
2803 -- Eval_String_Literal --
2804 -------------------------
2805
2806 procedure Eval_String_Literal (N : Node_Id) is
91b1417d
AC
2807 Typ : constant Entity_Id := Etype (N);
2808 Bas : constant Entity_Id := Base_Type (Typ);
2809 Xtp : Entity_Id;
2810 Len : Nat;
2811 Lo : Node_Id;
996ae0b0
RK
2812
2813 begin
2814 -- Nothing to do if error type (handles cases like default expressions
2815 -- or generics where we have not yet fully resolved the type)
2816
91b1417d 2817 if Bas = Any_Type or else Bas = Any_String then
996ae0b0 2818 return;
91b1417d 2819 end if;
996ae0b0
RK
2820
2821 -- String literals are static if the subtype is static (RM 4.9(2)), so
2822 -- reset the static expression flag (it was set unconditionally in
2823 -- Analyze_String_Literal) if the subtype is non-static. We tell if
2824 -- the subtype is static by looking at the lower bound.
2825
91b1417d
AC
2826 if Ekind (Typ) = E_String_Literal_Subtype then
2827 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
2828 Set_Is_Static_Expression (N, False);
2829 return;
2830 end if;
2831
2832 -- Here if Etype of string literal is normal Etype (not yet possible,
2833 -- but may be possible in future!)
2834
2835 elsif not Is_OK_Static_Expression
2836 (Type_Low_Bound (Etype (First_Index (Typ))))
2837 then
996ae0b0 2838 Set_Is_Static_Expression (N, False);
91b1417d
AC
2839 return;
2840 end if;
996ae0b0 2841
91b1417d
AC
2842 -- If original node was a type conversion, then result if non-static
2843
2844 if Nkind (Original_Node (N)) = N_Type_Conversion then
996ae0b0 2845 Set_Is_Static_Expression (N, False);
91b1417d
AC
2846 return;
2847 end if;
996ae0b0
RK
2848
2849 -- Test for illegal Ada 95 cases. A string literal is illegal in
2850 -- Ada 95 if its bounds are outside the index base type and this
91b1417d 2851 -- index type is static. This can happen in only two ways. Either
996ae0b0
RK
2852 -- the string literal is too long, or it is null, and the lower
2853 -- bound is type'First. In either case it is the upper bound that
2854 -- is out of range of the index type.
2855
0ab80019 2856 if Ada_Version >= Ada_95 then
91b1417d
AC
2857 if Root_Type (Bas) = Standard_String
2858 or else
2859 Root_Type (Bas) = Standard_Wide_String
996ae0b0 2860 then
91b1417d 2861 Xtp := Standard_Positive;
996ae0b0 2862 else
91b1417d 2863 Xtp := Etype (First_Index (Bas));
996ae0b0
RK
2864 end if;
2865
91b1417d
AC
2866 if Ekind (Typ) = E_String_Literal_Subtype then
2867 Lo := String_Literal_Low_Bound (Typ);
2868 else
2869 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
2870 end if;
2871
2872 Len := String_Length (Strval (N));
2873
2874 if UI_From_Int (Len) > String_Type_Len (Bas) then
996ae0b0 2875 Apply_Compile_Time_Constraint_Error
07fc65c4 2876 (N, "string literal too long for}", CE_Length_Check_Failed,
91b1417d
AC
2877 Ent => Bas,
2878 Typ => First_Subtype (Bas));
996ae0b0 2879
91b1417d
AC
2880 elsif Len = 0
2881 and then not Is_Generic_Type (Xtp)
2882 and then
2883 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
996ae0b0
RK
2884 then
2885 Apply_Compile_Time_Constraint_Error
2886 (N, "null string literal not allowed for}",
07fc65c4 2887 CE_Length_Check_Failed,
91b1417d
AC
2888 Ent => Bas,
2889 Typ => First_Subtype (Bas));
996ae0b0
RK
2890 end if;
2891 end if;
996ae0b0
RK
2892 end Eval_String_Literal;
2893
2894 --------------------------
2895 -- Eval_Type_Conversion --
2896 --------------------------
2897
2898 -- A type conversion is potentially static if its subtype mark is for a
2899 -- static scalar subtype, and its operand expression is potentially static
2900 -- (RM 4.9 (10))
2901
2902 procedure Eval_Type_Conversion (N : Node_Id) is
2903 Operand : constant Node_Id := Expression (N);
2904 Source_Type : constant Entity_Id := Etype (Operand);
2905 Target_Type : constant Entity_Id := Etype (N);
2906
2907 Stat : Boolean;
2908 Fold : Boolean;
2909
2910 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
2911 -- Returns true if type T is an integer type, or if it is a
2912 -- fixed-point type to be treated as an integer (i.e. the flag
2913 -- Conversion_OK is set on the conversion node).
2914
2915 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
2916 -- Returns true if type T is a floating-point type, or if it is a
2917 -- fixed-point type that is not to be treated as an integer (i.e. the
2918 -- flag Conversion_OK is not set on the conversion node).
2919
fbf5a39b
AC
2920 ------------------------------
2921 -- To_Be_Treated_As_Integer --
2922 ------------------------------
2923
996ae0b0
RK
2924 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
2925 begin
2926 return
2927 Is_Integer_Type (T)
2928 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
2929 end To_Be_Treated_As_Integer;
2930
fbf5a39b
AC
2931 ---------------------------
2932 -- To_Be_Treated_As_Real --
2933 ---------------------------
2934
996ae0b0
RK
2935 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
2936 begin
2937 return
2938 Is_Floating_Point_Type (T)
2939 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
2940 end To_Be_Treated_As_Real;
2941
2942 -- Start of processing for Eval_Type_Conversion
2943
2944 begin
82c80734 2945 -- Cannot fold if target type is non-static or if semantic error
996ae0b0
RK
2946
2947 if not Is_Static_Subtype (Target_Type) then
2948 Check_Non_Static_Context (Operand);
2949 return;
2950
2951 elsif Error_Posted (N) then
2952 return;
2953 end if;
2954
2955 -- If not foldable we are done
2956
2957 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2958
2959 if not Fold then
2960 return;
2961
2962 -- Don't try fold if target type has constraint error bounds
2963
2964 elsif not Is_OK_Static_Subtype (Target_Type) then
2965 Set_Raises_Constraint_Error (N);
2966 return;
2967 end if;
2968
2969 -- Remaining processing depends on operand types. Note that in the
2970 -- following type test, fixed-point counts as real unless the flag
2971 -- Conversion_OK is set, in which case it counts as integer.
2972
82c80734 2973 -- Fold conversion, case of string type. The result is not static
996ae0b0
RK
2974
2975 if Is_String_Type (Target_Type) then
b11e8d6f 2976 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
996ae0b0
RK
2977
2978 return;
2979
2980 -- Fold conversion, case of integer target type
2981
2982 elsif To_Be_Treated_As_Integer (Target_Type) then
2983 declare
2984 Result : Uint;
2985
2986 begin
2987 -- Integer to integer conversion
2988
2989 if To_Be_Treated_As_Integer (Source_Type) then
2990 Result := Expr_Value (Operand);
2991
2992 -- Real to integer conversion
2993
2994 else
2995 Result := UR_To_Uint (Expr_Value_R (Operand));
2996 end if;
2997
2998 -- If fixed-point type (Conversion_OK must be set), then the
2999 -- result is logically an integer, but we must replace the
3000 -- conversion with the corresponding real literal, since the
3001 -- type from a semantic point of view is still fixed-point.
3002
3003 if Is_Fixed_Point_Type (Target_Type) then
3004 Fold_Ureal
fbf5a39b 3005 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
996ae0b0
RK
3006
3007 -- Otherwise result is integer literal
3008
3009 else
fbf5a39b 3010 Fold_Uint (N, Result, Stat);
996ae0b0
RK
3011 end if;
3012 end;
3013
3014 -- Fold conversion, case of real target type
3015
3016 elsif To_Be_Treated_As_Real (Target_Type) then
3017 declare
3018 Result : Ureal;
3019
3020 begin
3021 if To_Be_Treated_As_Real (Source_Type) then
3022 Result := Expr_Value_R (Operand);
3023 else
3024 Result := UR_From_Uint (Expr_Value (Operand));
3025 end if;
3026
fbf5a39b 3027 Fold_Ureal (N, Result, Stat);
996ae0b0
RK
3028 end;
3029
3030 -- Enumeration types
3031
3032 else
fbf5a39b 3033 Fold_Uint (N, Expr_Value (Operand), Stat);
996ae0b0
RK
3034 end if;
3035
c800f862 3036 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
996ae0b0
RK
3037 Out_Of_Range (N);
3038 end if;
3039
3040 end Eval_Type_Conversion;
3041
3042 -------------------
3043 -- Eval_Unary_Op --
3044 -------------------
3045
3046 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3047 -- are potentially static if the operand is potentially static (RM 4.9(7))
3048
3049 procedure Eval_Unary_Op (N : Node_Id) is
3050 Right : constant Node_Id := Right_Opnd (N);
3051 Stat : Boolean;
3052 Fold : Boolean;
3053
3054 begin
3055 -- If not foldable we are done
3056
3057 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3058
3059 if not Fold then
3060 return;
3061 end if;
3062
3063 -- Fold for integer case
3064
3065 if Is_Integer_Type (Etype (N)) then
3066 declare
3067 Rint : constant Uint := Expr_Value (Right);
3068 Result : Uint;
3069
3070 begin
3071 -- In the case of modular unary plus and abs there is no need
3072 -- to adjust the result of the operation since if the original
3073 -- operand was in bounds the result will be in the bounds of the
3074 -- modular type. However, in the case of modular unary minus the
3075 -- result may go out of the bounds of the modular type and needs
3076 -- adjustment.
3077
3078 if Nkind (N) = N_Op_Plus then
3079 Result := Rint;
3080
3081 elsif Nkind (N) = N_Op_Minus then
3082 if Is_Modular_Integer_Type (Etype (N)) then
3083 Result := (-Rint) mod Modulus (Etype (N));
3084 else
3085 Result := (-Rint);
3086 end if;
3087
3088 else
3089 pragma Assert (Nkind (N) = N_Op_Abs);
3090 Result := abs Rint;
3091 end if;
3092
fbf5a39b 3093 Fold_Uint (N, Result, Stat);
996ae0b0
RK
3094 end;
3095
3096 -- Fold for real case
3097
3098 elsif Is_Real_Type (Etype (N)) then
3099 declare
3100 Rreal : constant Ureal := Expr_Value_R (Right);
3101 Result : Ureal;
3102
3103 begin
3104 if Nkind (N) = N_Op_Plus then
3105 Result := Rreal;
3106
3107 elsif Nkind (N) = N_Op_Minus then
3108 Result := UR_Negate (Rreal);
3109
3110 else
3111 pragma Assert (Nkind (N) = N_Op_Abs);
3112 Result := abs Rreal;
3113 end if;
3114
fbf5a39b 3115 Fold_Ureal (N, Result, Stat);
996ae0b0
RK
3116 end;
3117 end if;
996ae0b0
RK
3118 end Eval_Unary_Op;
3119
3120 -------------------------------
3121 -- Eval_Unchecked_Conversion --
3122 -------------------------------
3123
3124 -- Unchecked conversions can never be static, so the only required
3125 -- processing is to check for a non-static context for the operand.
3126
3127 procedure Eval_Unchecked_Conversion (N : Node_Id) is
3128 begin
3129 Check_Non_Static_Context (Expression (N));
3130 end Eval_Unchecked_Conversion;
3131
3132 --------------------
3133 -- Expr_Rep_Value --
3134 --------------------
3135
3136 function Expr_Rep_Value (N : Node_Id) return Uint is
07fc65c4
GB
3137 Kind : constant Node_Kind := Nkind (N);
3138 Ent : Entity_Id;
996ae0b0
RK
3139
3140 begin
3141 if Is_Entity_Name (N) then
3142 Ent := Entity (N);
3143
3144 -- An enumeration literal that was either in the source or
3145 -- created as a result of static evaluation.
3146
3147 if Ekind (Ent) = E_Enumeration_Literal then
3148 return Enumeration_Rep (Ent);
3149
3150 -- A user defined static constant
3151
3152 else
3153 pragma Assert (Ekind (Ent) = E_Constant);
3154 return Expr_Rep_Value (Constant_Value (Ent));
3155 end if;
3156
3157 -- An integer literal that was either in the source or created
3158 -- as a result of static evaluation.
3159
3160 elsif Kind = N_Integer_Literal then
3161 return Intval (N);
3162
3163 -- A real literal for a fixed-point type. This must be the fixed-point
3164 -- case, either the literal is of a fixed-point type, or it is a bound
3165 -- of a fixed-point type, with type universal real. In either case we
3166 -- obtain the desired value from Corresponding_Integer_Value.
3167
3168 elsif Kind = N_Real_Literal then
996ae0b0
RK
3169 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3170 return Corresponding_Integer_Value (N);
3171
07fc65c4
GB
3172 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3173
3174 elsif Kind = N_Attribute_Reference
3175 and then Attribute_Name (N) = Name_Null_Parameter
3176 then
3177 return Uint_0;
3178
07fc65c4 3179 -- Otherwise must be character literal
8cbb664e 3180
996ae0b0
RK
3181 else
3182 pragma Assert (Kind = N_Character_Literal);
3183 Ent := Entity (N);
3184
3185 -- Since Character literals of type Standard.Character don't
3186 -- have any defining character literals built for them, they
3187 -- do not have their Entity set, so just use their Char
3188 -- code. Otherwise for user-defined character literals use
3189 -- their Pos value as usual which is the same as the Rep value.
3190
3191 if No (Ent) then
82c80734 3192 return Char_Literal_Value (N);
996ae0b0
RK
3193 else
3194 return Enumeration_Rep (Ent);
3195 end if;
3196 end if;
3197 end Expr_Rep_Value;
3198
3199 ----------------
3200 -- Expr_Value --
3201 ----------------
3202
3203 function Expr_Value (N : Node_Id) return Uint is
07fc65c4
GB
3204 Kind : constant Node_Kind := Nkind (N);
3205 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3206 Ent : Entity_Id;
3207 Val : Uint;
996ae0b0
RK
3208
3209 begin
13f34a3f
RD
3210 -- If already in cache, then we know it's compile time known and we can
3211 -- return the value that was previously stored in the cache since
3212 -- compile time known values cannot change.
07fc65c4
GB
3213
3214 if CV_Ent.N = N then
3215 return CV_Ent.V;
3216 end if;
3217
3218 -- Otherwise proceed to test value
3219
996ae0b0
RK
3220 if Is_Entity_Name (N) then
3221 Ent := Entity (N);
3222
3223 -- An enumeration literal that was either in the source or
3224 -- created as a result of static evaluation.
3225
3226 if Ekind (Ent) = E_Enumeration_Literal then
07fc65c4 3227 Val := Enumeration_Pos (Ent);
996ae0b0
RK
3228
3229 -- A user defined static constant
3230
3231 else
3232 pragma Assert (Ekind (Ent) = E_Constant);
07fc65c4 3233 Val := Expr_Value (Constant_Value (Ent));
996ae0b0
RK
3234 end if;
3235
3236 -- An integer literal that was either in the source or created
3237 -- as a result of static evaluation.
3238
3239 elsif Kind = N_Integer_Literal then
07fc65c4 3240 Val := Intval (N);
996ae0b0
RK
3241
3242 -- A real literal for a fixed-point type. This must be the fixed-point
3243 -- case, either the literal is of a fixed-point type, or it is a bound
3244 -- of a fixed-point type, with type universal real. In either case we
3245 -- obtain the desired value from Corresponding_Integer_Value.
3246
3247 elsif Kind = N_Real_Literal then
3248
996ae0b0 3249 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
07fc65c4 3250 Val := Corresponding_Integer_Value (N);
996ae0b0
RK
3251
3252 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3253
3254 elsif Kind = N_Attribute_Reference
3255 and then Attribute_Name (N) = Name_Null_Parameter
3256 then
07fc65c4
GB
3257 Val := Uint_0;
3258
996ae0b0
RK
3259 -- Otherwise must be character literal
3260
3261 else
3262 pragma Assert (Kind = N_Character_Literal);
3263 Ent := Entity (N);
3264
3265 -- Since Character literals of type Standard.Character don't
3266 -- have any defining character literals built for them, they
3267 -- do not have their Entity set, so just use their Char
3268 -- code. Otherwise for user-defined character literals use
3269 -- their Pos value as usual.
3270
3271 if No (Ent) then
82c80734 3272 Val := Char_Literal_Value (N);
996ae0b0 3273 else
07fc65c4 3274 Val := Enumeration_Pos (Ent);
996ae0b0
RK
3275 end if;
3276 end if;
3277
07fc65c4
GB
3278 -- Come here with Val set to value to be returned, set cache
3279
3280 CV_Ent.N := N;
3281 CV_Ent.V := Val;
3282 return Val;
996ae0b0
RK
3283 end Expr_Value;
3284
3285 ------------------
3286 -- Expr_Value_E --
3287 ------------------
3288
3289 function Expr_Value_E (N : Node_Id) return Entity_Id is
3290 Ent : constant Entity_Id := Entity (N);
3291
3292 begin
3293 if Ekind (Ent) = E_Enumeration_Literal then
3294 return Ent;
3295 else
3296 pragma Assert (Ekind (Ent) = E_Constant);
3297 return Expr_Value_E (Constant_Value (Ent));
3298 end if;
3299 end Expr_Value_E;
3300
3301 ------------------
3302 -- Expr_Value_R --
3303 ------------------
3304
3305 function Expr_Value_R (N : Node_Id) return Ureal is
3306 Kind : constant Node_Kind := Nkind (N);
3307 Ent : Entity_Id;
3308 Expr : Node_Id;
3309
3310 begin
3311 if Kind = N_Real_Literal then
3312 return Realval (N);
3313
3314 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3315 Ent := Entity (N);
3316 pragma Assert (Ekind (Ent) = E_Constant);
3317 return Expr_Value_R (Constant_Value (Ent));
3318
3319 elsif Kind = N_Integer_Literal then
3320 return UR_From_Uint (Expr_Value (N));
3321
3322 -- Strange case of VAX literals, which are at this stage transformed
3323 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3324 -- Exp_Vfpt for further details.
3325
3326 elsif Vax_Float (Etype (N))
3327 and then Nkind (N) = N_Unchecked_Type_Conversion
3328 then
3329 Expr := Expression (N);
3330
3331 if Nkind (Expr) = N_Function_Call
3332 and then Present (Parameter_Associations (Expr))
3333 then
3334 Expr := First (Parameter_Associations (Expr));
3335
3336 if Nkind (Expr) = N_Real_Literal then
3337 return Realval (Expr);
3338 end if;
3339 end if;
3340
3341 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3342
3343 elsif Kind = N_Attribute_Reference
3344 and then Attribute_Name (N) = Name_Null_Parameter
3345 then
3346 return Ureal_0;
3347 end if;
3348
f3d57416 3349 -- If we fall through, we have a node that cannot be interpreted
996ae0b0
RK
3350 -- as a compile time constant. That is definitely an error.
3351
3352 raise Program_Error;
3353 end Expr_Value_R;
3354
3355 ------------------
3356 -- Expr_Value_S --
3357 ------------------
3358
3359 function Expr_Value_S (N : Node_Id) return Node_Id is
3360 begin
3361 if Nkind (N) = N_String_Literal then
3362 return N;
3363 else
3364 pragma Assert (Ekind (Entity (N)) = E_Constant);
3365 return Expr_Value_S (Constant_Value (Entity (N)));
3366 end if;
3367 end Expr_Value_S;
3368
fbf5a39b
AC
3369 --------------------------
3370 -- Flag_Non_Static_Expr --
3371 --------------------------
3372
3373 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
3374 begin
3375 if Error_Posted (Expr) and then not All_Errors_Mode then
3376 return;
3377 else
3378 Error_Msg_F (Msg, Expr);
3379 Why_Not_Static (Expr);
3380 end if;
3381 end Flag_Non_Static_Expr;
3382
996ae0b0
RK
3383 --------------
3384 -- Fold_Str --
3385 --------------
3386
fbf5a39b 3387 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
996ae0b0
RK
3388 Loc : constant Source_Ptr := Sloc (N);
3389 Typ : constant Entity_Id := Etype (N);
3390
3391 begin
3392 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
fbf5a39b
AC
3393
3394 -- We now have the literal with the right value, both the actual type
3395 -- and the expected type of this literal are taken from the expression
3396 -- that was evaluated.
3397
3398 Analyze (N);
3399 Set_Is_Static_Expression (N, Static);
3400 Set_Etype (N, Typ);
3401 Resolve (N);
996ae0b0
RK
3402 end Fold_Str;
3403
3404 ---------------
3405 -- Fold_Uint --
3406 ---------------
3407
fbf5a39b 3408 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
996ae0b0 3409 Loc : constant Source_Ptr := Sloc (N);
fbf5a39b
AC
3410 Typ : Entity_Id := Etype (N);
3411 Ent : Entity_Id;
996ae0b0
RK
3412
3413 begin
fbf5a39b
AC
3414 -- If we are folding a named number, retain the entity in the
3415 -- literal, for ASIS use.
3416
3417 if Is_Entity_Name (N)
3418 and then Ekind (Entity (N)) = E_Named_Integer
3419 then
3420 Ent := Entity (N);
3421 else
3422 Ent := Empty;
3423 end if;
3424
3425 if Is_Private_Type (Typ) then
3426 Typ := Full_View (Typ);
3427 end if;
3428
f3d57416 3429 -- For a result of type integer, substitute an N_Integer_Literal node
996ae0b0 3430 -- for the result of the compile time evaluation of the expression.
cd2fb920
ES
3431 -- For ASIS use, set a link to the original named number when not in
3432 -- a generic context.
996ae0b0 3433
fbf5a39b 3434 if Is_Integer_Type (Typ) then
996ae0b0 3435 Rewrite (N, Make_Integer_Literal (Loc, Val));
cd2fb920 3436
fbf5a39b 3437 Set_Original_Entity (N, Ent);
996ae0b0
RK
3438
3439 -- Otherwise we have an enumeration type, and we substitute either
3440 -- an N_Identifier or N_Character_Literal to represent the enumeration
3441 -- literal corresponding to the given value, which must always be in
3442 -- range, because appropriate tests have already been made for this.
3443
fbf5a39b 3444 else pragma Assert (Is_Enumeration_Type (Typ));
996ae0b0
RK
3445 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
3446 end if;
3447
3448 -- We now have the literal with the right value, both the actual type
3449 -- and the expected type of this literal are taken from the expression
3450 -- that was evaluated.
3451
3452 Analyze (N);
fbf5a39b 3453 Set_Is_Static_Expression (N, Static);
996ae0b0 3454 Set_Etype (N, Typ);
fbf5a39b 3455 Resolve (N);
996ae0b0
RK
3456 end Fold_Uint;
3457
3458 ----------------
3459 -- Fold_Ureal --
3460 ----------------
3461
fbf5a39b 3462 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
996ae0b0
RK
3463 Loc : constant Source_Ptr := Sloc (N);
3464 Typ : constant Entity_Id := Etype (N);
fbf5a39b 3465 Ent : Entity_Id;
996ae0b0
RK
3466
3467 begin
fbf5a39b
AC
3468 -- If we are folding a named number, retain the entity in the
3469 -- literal, for ASIS use.
3470
3471 if Is_Entity_Name (N)
3472 and then Ekind (Entity (N)) = E_Named_Real
3473 then
3474 Ent := Entity (N);
3475 else
3476 Ent := Empty;
3477 end if;
3478
996ae0b0 3479 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
cd2fb920 3480
5a30024a 3481 -- Set link to original named number, for ASIS use
cd2fb920 3482
fbf5a39b 3483 Set_Original_Entity (N, Ent);
996ae0b0
RK
3484
3485 -- Both the actual and expected type comes from the original expression
3486
fbf5a39b
AC
3487 Analyze (N);
3488 Set_Is_Static_Expression (N, Static);
996ae0b0 3489 Set_Etype (N, Typ);
fbf5a39b 3490 Resolve (N);
996ae0b0
RK
3491 end Fold_Ureal;
3492
3493 ---------------
3494 -- From_Bits --
3495 ---------------
3496
3497 function From_Bits (B : Bits; T : Entity_Id) return Uint is
3498 V : Uint := Uint_0;
3499
3500 begin
3501 for J in 0 .. B'Last loop
3502 if B (J) then
3503 V := V + 2 ** J;
3504 end if;
3505 end loop;
3506
3507 if Non_Binary_Modulus (T) then
3508 V := V mod Modulus (T);
3509 end if;
3510
3511 return V;
3512 end From_Bits;
3513
3514 --------------------
3515 -- Get_String_Val --
3516 --------------------
3517
3518 function Get_String_Val (N : Node_Id) return Node_Id is
3519 begin
3520 if Nkind (N) = N_String_Literal then
3521 return N;
3522
3523 elsif Nkind (N) = N_Character_Literal then
3524 return N;
3525
3526 else
3527 pragma Assert (Is_Entity_Name (N));
3528 return Get_String_Val (Constant_Value (Entity (N)));
3529 end if;
3530 end Get_String_Val;
3531
fbf5a39b
AC
3532 ----------------
3533 -- Initialize --
3534 ----------------
3535
3536 procedure Initialize is
3537 begin
3538 CV_Cache := (others => (Node_High_Bound, Uint_0));
3539 end Initialize;
3540
996ae0b0
RK
3541 --------------------
3542 -- In_Subrange_Of --
3543 --------------------
3544
3545 function In_Subrange_Of
c27f2f15
RD
3546 (T1 : Entity_Id;
3547 T2 : Entity_Id;
3548 Fixed_Int : Boolean := False) return Boolean
996ae0b0
RK
3549 is
3550 L1 : Node_Id;
3551 H1 : Node_Id;
3552
3553 L2 : Node_Id;
3554 H2 : Node_Id;
3555
3556 begin
3557 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
3558 return True;
3559
3560 -- Never in range if both types are not scalar. Don't know if this can
3561 -- actually happen, but just in case.
3562
3563 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
3564 return False;
3565
3566 else
3567 L1 := Type_Low_Bound (T1);
3568 H1 := Type_High_Bound (T1);
3569
3570 L2 := Type_Low_Bound (T2);
3571 H2 := Type_High_Bound (T2);
3572
3573 -- Check bounds to see if comparison possible at compile time
3574
c27f2f15 3575 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
996ae0b0 3576 and then
c27f2f15 3577 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
996ae0b0
RK
3578 then
3579 return True;
3580 end if;
3581
3582 -- If bounds not comparable at compile time, then the bounds of T2
3583 -- must be compile time known or we cannot answer the query.
3584
3585 if not Compile_Time_Known_Value (L2)
3586 or else not Compile_Time_Known_Value (H2)
3587 then
3588 return False;
3589 end if;
3590
3591 -- If the bounds of T1 are know at compile time then use these
3592 -- ones, otherwise use the bounds of the base type (which are of
3593 -- course always static).
3594
3595 if not Compile_Time_Known_Value (L1) then
3596 L1 := Type_Low_Bound (Base_Type (T1));
3597 end if;
3598
3599 if not Compile_Time_Known_Value (H1) then
3600 H1 := Type_High_Bound (Base_Type (T1));
3601 end if;
3602
3603 -- Fixed point types should be considered as such only if
3604 -- flag Fixed_Int is set to False.
3605
3606 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
3607 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
3608 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
3609 then
3610 return
3611 Expr_Value_R (L2) <= Expr_Value_R (L1)
3612 and then
3613 Expr_Value_R (H2) >= Expr_Value_R (H1);
3614
3615 else
3616 return
3617 Expr_Value (L2) <= Expr_Value (L1)
3618 and then
3619 Expr_Value (H2) >= Expr_Value (H1);
3620
3621 end if;
3622 end if;
3623
3624 -- If any exception occurs, it means that we have some bug in the compiler
f3d57416 3625 -- possibly triggered by a previous error, or by some unforeseen peculiar
996ae0b0
RK
3626 -- occurrence. However, this is only an optimization attempt, so there is
3627 -- really no point in crashing the compiler. Instead we just decide, too
3628 -- bad, we can't figure out the answer in this case after all.
3629
3630 exception
3631 when others =>
3632
3633 -- Debug flag K disables this behavior (useful for debugging)
3634
3635 if Debug_Flag_K then
3636 raise;
3637 else
3638 return False;
3639 end if;
3640 end In_Subrange_Of;
3641
3642 -----------------
3643 -- Is_In_Range --
3644 -----------------
3645
3646 function Is_In_Range
c800f862
RD
3647 (N : Node_Id;
3648 Typ : Entity_Id;
3649 Assume_Valid : Boolean := False;
3650 Fixed_Int : Boolean := False;
3651 Int_Real : Boolean := False) return Boolean
996ae0b0
RK
3652 is
3653 Val : Uint;
3654 Valr : Ureal;
3655
c27f2f15
RD
3656 pragma Warnings (Off, Assume_Valid);
3657 -- For now Assume_Valid is unreferenced since the current implementation
3658 -- always returns False if N is not a compile time known value, but we
3659 -- keep the parameter to allow for future enhancements in which we try
3660 -- to get the information in the variable case as well.
3661
996ae0b0 3662 begin
82c80734 3663 -- Universal types have no range limits, so always in range
996ae0b0
RK
3664
3665 if Typ = Universal_Integer or else Typ = Universal_Real then
3666 return True;
3667
3668 -- Never in range if not scalar type. Don't know if this can
3669 -- actually happen, but our spec allows it, so we must check!
3670
3671 elsif not Is_Scalar_Type (Typ) then
3672 return False;
3673
82c80734 3674 -- Never in range unless we have a compile time known value
996ae0b0
RK
3675
3676 elsif not Compile_Time_Known_Value (N) then
3677 return False;
3678
c800f862
RD
3679 -- General processing with a known compile time value
3680
996ae0b0
RK
3681 else
3682 declare
c800f862
RD
3683 Lo : Node_Id;
3684 Hi : Node_Id;
3685 LB_Known : Boolean;
3686 UB_Known : Boolean;
996ae0b0
RK
3687
3688 begin
c27f2f15
RD
3689 Lo := Type_Low_Bound (Typ);
3690 Hi := Type_High_Bound (Typ);
c800f862
RD
3691
3692 LB_Known := Compile_Time_Known_Value (Lo);
3693 UB_Known := Compile_Time_Known_Value (Hi);
3694
996ae0b0
RK
3695 -- Fixed point types should be considered as such only in
3696 -- flag Fixed_Int is set to False.
3697
c27f2f15
RD
3698 if Is_Floating_Point_Type (Typ)
3699 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
996ae0b0
RK
3700 or else Int_Real
3701 then
3702 Valr := Expr_Value_R (N);
3703
3704 if LB_Known and then Valr >= Expr_Value_R (Lo)
3705 and then UB_Known and then Valr <= Expr_Value_R (Hi)
3706 then
3707 return True;
3708 else
3709 return False;
3710 end if;
3711
3712 else
3713 Val := Expr_Value (N);
3714
3715 if LB_Known and then Val >= Expr_Value (Lo)
3716 and then UB_Known and then Val <= Expr_Value (Hi)
3717 then
3718 return True;
3719 else
3720 return False;
3721 end if;
3722 end if;
3723 end;
3724 end if;
3725 end Is_In_Range;
3726
3727 -------------------
3728 -- Is_Null_Range --
3729 -------------------
3730
3731 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3732 Typ : constant Entity_Id := Etype (Lo);
3733
3734 begin
3735 if not Compile_Time_Known_Value (Lo)
3736 or else not Compile_Time_Known_Value (Hi)
3737 then
3738 return False;
3739 end if;
3740
3741 if Is_Discrete_Type (Typ) then
3742 return Expr_Value (Lo) > Expr_Value (Hi);
3743
3744 else
3745 pragma Assert (Is_Real_Type (Typ));
3746 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
3747 end if;
3748 end Is_Null_Range;
3749
3750 -----------------------------
3751 -- Is_OK_Static_Expression --
3752 -----------------------------
3753
3754 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
3755 begin
3756 return Is_Static_Expression (N)
3757 and then not Raises_Constraint_Error (N);
3758 end Is_OK_Static_Expression;
3759
3760 ------------------------
3761 -- Is_OK_Static_Range --
3762 ------------------------
3763
3764 -- A static range is a range whose bounds are static expressions, or a
3765 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3766 -- We have already converted range attribute references, so we get the
3767 -- "or" part of this rule without needing a special test.
3768
3769 function Is_OK_Static_Range (N : Node_Id) return Boolean is
3770 begin
3771 return Is_OK_Static_Expression (Low_Bound (N))
3772 and then Is_OK_Static_Expression (High_Bound (N));
3773 end Is_OK_Static_Range;
3774
3775 --------------------------
3776 -- Is_OK_Static_Subtype --
3777 --------------------------
3778
3779 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
3780 -- where neither bound raises constraint error when evaluated.
3781
3782 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
3783 Base_T : constant Entity_Id := Base_Type (Typ);
3784 Anc_Subt : Entity_Id;
3785
3786 begin
3787 -- First a quick check on the non static subtype flag. As described
3788 -- in further detail in Einfo, this flag is not decisive in all cases,
3789 -- but if it is set, then the subtype is definitely non-static.
3790
3791 if Is_Non_Static_Subtype (Typ) then
3792 return False;
3793 end if;
3794
3795 Anc_Subt := Ancestor_Subtype (Typ);
3796
3797 if Anc_Subt = Empty then
3798 Anc_Subt := Base_T;
3799 end if;
3800
3801 if Is_Generic_Type (Root_Type (Base_T))
3802 or else Is_Generic_Actual_Type (Base_T)
3803 then
3804 return False;
3805
3806 -- String types
3807
3808 elsif Is_String_Type (Typ) then
3809 return
3810 Ekind (Typ) = E_String_Literal_Subtype
3811 or else
3812 (Is_OK_Static_Subtype (Component_Type (Typ))
3813 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
3814
3815 -- Scalar types
3816
3817 elsif Is_Scalar_Type (Typ) then
3818 if Base_T = Typ then
3819 return True;
3820
3821 else
3822 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so
3823 -- use Get_Type_Low,High_Bound.
3824
3825 return Is_OK_Static_Subtype (Anc_Subt)
3826 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
3827 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
3828 end if;
3829
3830 -- Types other than string and scalar types are never static
3831
3832 else
3833 return False;
3834 end if;
3835 end Is_OK_Static_Subtype;
3836
3837 ---------------------
3838 -- Is_Out_Of_Range --
3839 ---------------------
3840
3841 function Is_Out_Of_Range
1c7717c3
AC
3842 (N : Node_Id;
3843 Typ : Entity_Id;
c800f862 3844 Assume_Valid : Boolean := False;
1c7717c3
AC
3845 Fixed_Int : Boolean := False;
3846 Int_Real : Boolean := False) return Boolean
996ae0b0
RK
3847 is
3848 Val : Uint;
3849 Valr : Ureal;
3850
c27f2f15
RD
3851 pragma Warnings (Off, Assume_Valid);
3852 -- For now Assume_Valid is unreferenced since the current implementation
3853 -- always returns False if N is not a compile time known value, but we
3854 -- keep the parameter to allow for future enhancements in which we try
3855 -- to get the information in the variable case as well.
3856
996ae0b0 3857 begin
82c80734 3858 -- Universal types have no range limits, so always in range
996ae0b0
RK
3859
3860 if Typ = Universal_Integer or else Typ = Universal_Real then
3861 return False;
3862
3863 -- Never out of range if not scalar type. Don't know if this can
3864 -- actually happen, but our spec allows it, so we must check!
3865
3866 elsif not Is_Scalar_Type (Typ) then
3867 return False;
3868
3869 -- Never out of range if this is a generic type, since the bounds
3870 -- of generic types are junk. Note that if we only checked for
3871 -- static expressions (instead of compile time known values) below,
3872 -- we would not need this check, because values of a generic type
3873 -- can never be static, but they can be known at compile time.
3874
3875 elsif Is_Generic_Type (Typ) then
3876 return False;
3877
fbf5a39b 3878 -- Never out of range unless we have a compile time known value
996ae0b0
RK
3879
3880 elsif not Compile_Time_Known_Value (N) then
3881 return False;
3882
3883 else
3884 declare
c800f862
RD
3885 Lo : Node_Id;
3886 Hi : Node_Id;
3887 LB_Known : Boolean;
3888 UB_Known : Boolean;
996ae0b0
RK
3889
3890 begin
c27f2f15
RD
3891 Lo := Type_Low_Bound (Typ);
3892 Hi := Type_High_Bound (Typ);
c800f862
RD
3893
3894 LB_Known := Compile_Time_Known_Value (Lo);
3895 UB_Known := Compile_Time_Known_Value (Hi);
3896
996ae0b0
RK
3897 -- Real types (note that fixed-point types are not treated
3898 -- as being of a real type if the flag Fixed_Int is set,
3899 -- since in that case they are regarded as integer types).
3900
c27f2f15
RD
3901 if Is_Floating_Point_Type (Typ)
3902 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
996ae0b0
RK
3903 or else Int_Real
3904 then
3905 Valr := Expr_Value_R (N);
3906
3907 if LB_Known and then Valr < Expr_Value_R (Lo) then
3908 return True;
3909
3910 elsif UB_Known and then Expr_Value_R (Hi) < Valr then
3911 return True;
3912
3913 else
3914 return False;
3915 end if;
3916
3917 else
3918 Val := Expr_Value (N);
3919
3920 if LB_Known and then Val < Expr_Value (Lo) then
3921 return True;
3922
3923 elsif UB_Known and then Expr_Value (Hi) < Val then
3924 return True;
3925
3926 else
3927 return False;
3928 end if;
3929 end if;
3930 end;
3931 end if;
3932 end Is_Out_Of_Range;
3933
3934 ---------------------
3935 -- Is_Static_Range --
3936 ---------------------
3937
3938 -- A static range is a range whose bounds are static expressions, or a
3939 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3940 -- We have already converted range attribute references, so we get the
3941 -- "or" part of this rule without needing a special test.
3942
3943 function Is_Static_Range (N : Node_Id) return Boolean is
3944 begin
3945 return Is_Static_Expression (Low_Bound (N))
3946 and then Is_Static_Expression (High_Bound (N));
3947 end Is_Static_Range;
3948
3949 -----------------------
3950 -- Is_Static_Subtype --
3951 -----------------------
3952
82c80734 3953 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
996ae0b0
RK
3954
3955 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
3956 Base_T : constant Entity_Id := Base_Type (Typ);
3957 Anc_Subt : Entity_Id;
3958
3959 begin
3960 -- First a quick check on the non static subtype flag. As described
3961 -- in further detail in Einfo, this flag is not decisive in all cases,
3962 -- but if it is set, then the subtype is definitely non-static.
3963
3964 if Is_Non_Static_Subtype (Typ) then
3965 return False;
3966 end if;
3967
3968 Anc_Subt := Ancestor_Subtype (Typ);
3969
3970 if Anc_Subt = Empty then
3971 Anc_Subt := Base_T;
3972 end if;
3973
3974 if Is_Generic_Type (Root_Type (Base_T))
3975 or else Is_Generic_Actual_Type (Base_T)
3976 then
3977 return False;
3978
3979 -- String types
3980
3981 elsif Is_String_Type (Typ) then
3982 return
3983 Ekind (Typ) = E_String_Literal_Subtype
3984 or else
3985 (Is_Static_Subtype (Component_Type (Typ))
3986 and then Is_Static_Subtype (Etype (First_Index (Typ))));
3987
3988 -- Scalar types
3989
3990 elsif Is_Scalar_Type (Typ) then
3991 if Base_T = Typ then
3992 return True;
3993
3994 else
3995 return Is_Static_Subtype (Anc_Subt)
3996 and then Is_Static_Expression (Type_Low_Bound (Typ))
3997 and then Is_Static_Expression (Type_High_Bound (Typ));
3998 end if;
3999
4000 -- Types other than string and scalar types are never static
4001
4002 else
4003 return False;
4004 end if;
4005 end Is_Static_Subtype;
4006
4007 --------------------
4008 -- Not_Null_Range --
4009 --------------------
4010
4011 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4012 Typ : constant Entity_Id := Etype (Lo);
4013
4014 begin
4015 if not Compile_Time_Known_Value (Lo)
4016 or else not Compile_Time_Known_Value (Hi)
4017 then
4018 return False;
4019 end if;
4020
4021 if Is_Discrete_Type (Typ) then
4022 return Expr_Value (Lo) <= Expr_Value (Hi);
4023
4024 else
4025 pragma Assert (Is_Real_Type (Typ));
4026
4027 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
4028 end if;
4029 end Not_Null_Range;
4030
4031 -------------
4032 -- OK_Bits --
4033 -------------
4034
4035 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
4036 begin
4037 -- We allow a maximum of 500,000 bits which seems a reasonable limit
4038
4039 if Bits < 500_000 then
4040 return True;
4041
4042 else
4043 Error_Msg_N ("static value too large, capacity exceeded", N);
4044 return False;
4045 end if;
4046 end OK_Bits;
4047
4048 ------------------
4049 -- Out_Of_Range --
4050 ------------------
4051
4052 procedure Out_Of_Range (N : Node_Id) is
4053 begin
4054 -- If we have the static expression case, then this is an illegality
4055 -- in Ada 95 mode, except that in an instance, we never generate an
4056 -- error (if the error is legitimate, it was already diagnosed in
4057 -- the template). The expression to compute the length of a packed
4058 -- array is attached to the array type itself, and deserves a separate
4059 -- message.
4060
4061 if Is_Static_Expression (N)
4062 and then not In_Instance
fbf5a39b 4063 and then not In_Inlined_Body
0ab80019 4064 and then Ada_Version >= Ada_95
996ae0b0 4065 then
996ae0b0
RK
4066 if Nkind (Parent (N)) = N_Defining_Identifier
4067 and then Is_Array_Type (Parent (N))
4068 and then Present (Packed_Array_Type (Parent (N)))
4069 and then Present (First_Rep_Item (Parent (N)))
4070 then
4071 Error_Msg_N
4072 ("length of packed array must not exceed Integer''Last",
4073 First_Rep_Item (Parent (N)));
4074 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
4075
4076 else
4077 Apply_Compile_Time_Constraint_Error
07fc65c4 4078 (N, "value not in range of}", CE_Range_Check_Failed);
996ae0b0
RK
4079 end if;
4080
4081 -- Here we generate a warning for the Ada 83 case, or when we are
4082 -- in an instance, or when we have a non-static expression case.
4083
4084 else
996ae0b0 4085 Apply_Compile_Time_Constraint_Error
07fc65c4 4086 (N, "value not in range of}?", CE_Range_Check_Failed);
996ae0b0
RK
4087 end if;
4088 end Out_Of_Range;
4089
4090 -------------------------
4091 -- Rewrite_In_Raise_CE --
4092 -------------------------
4093
4094 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
4095 Typ : constant Entity_Id := Etype (N);
4096
4097 begin
4098 -- If we want to raise CE in the condition of a raise_CE node
4099 -- we may as well get rid of the condition
4100
4101 if Present (Parent (N))
4102 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
4103 then
4104 Set_Condition (Parent (N), Empty);
4105
4106 -- If the expression raising CE is a N_Raise_CE node, we can use
4107 -- that one. We just preserve the type of the context
4108
4109 elsif Nkind (Exp) = N_Raise_Constraint_Error then
4110 Rewrite (N, Exp);
4111 Set_Etype (N, Typ);
4112
4113 -- We have to build an explicit raise_ce node
4114
4115 else
07fc65c4
GB
4116 Rewrite (N,
4117 Make_Raise_Constraint_Error (Sloc (Exp),
4118 Reason => CE_Range_Check_Failed));
996ae0b0
RK
4119 Set_Raises_Constraint_Error (N);
4120 Set_Etype (N, Typ);
4121 end if;
4122 end Rewrite_In_Raise_CE;
4123
4124 ---------------------
4125 -- String_Type_Len --
4126 ---------------------
4127
4128 function String_Type_Len (Stype : Entity_Id) return Uint is
4129 NT : constant Entity_Id := Etype (First_Index (Stype));
4130 T : Entity_Id;
4131
4132 begin
4133 if Is_OK_Static_Subtype (NT) then
4134 T := NT;
4135 else
4136 T := Base_Type (NT);
4137 end if;
4138
4139 return Expr_Value (Type_High_Bound (T)) -
4140 Expr_Value (Type_Low_Bound (T)) + 1;
4141 end String_Type_Len;
4142
4143 ------------------------------------
4144 -- Subtypes_Statically_Compatible --
4145 ------------------------------------
4146
4147 function Subtypes_Statically_Compatible
f44fe430
RD
4148 (T1 : Entity_Id;
4149 T2 : Entity_Id) return Boolean
996ae0b0
RK
4150 is
4151 begin
4152 if Is_Scalar_Type (T1) then
4153
4154 -- Definitely compatible if we match
4155
4156 if Subtypes_Statically_Match (T1, T2) then
4157 return True;
4158
4159 -- If either subtype is nonstatic then they're not compatible
4160
4161 elsif not Is_Static_Subtype (T1)
4162 or else not Is_Static_Subtype (T2)
4163 then
4164 return False;
4165
4166 -- If either type has constraint error bounds, then consider that
4167 -- they match to avoid junk cascaded errors here.
4168
4169 elsif not Is_OK_Static_Subtype (T1)
4170 or else not Is_OK_Static_Subtype (T2)
4171 then
4172 return True;
4173
4174 -- Base types must match, but we don't check that (should
4175 -- we???) but we do at least check that both types are
4176 -- real, or both types are not real.
4177
fbf5a39b 4178 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
996ae0b0
RK
4179 return False;
4180
4181 -- Here we check the bounds
4182
4183 else
4184 declare
4185 LB1 : constant Node_Id := Type_Low_Bound (T1);
4186 HB1 : constant Node_Id := Type_High_Bound (T1);
4187 LB2 : constant Node_Id := Type_Low_Bound (T2);
4188 HB2 : constant Node_Id := Type_High_Bound (T2);
4189
4190 begin
4191 if Is_Real_Type (T1) then
4192 return
4193 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4194 or else
4195 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4196 and then
4197 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4198
4199 else
4200 return
4201 (Expr_Value (LB1) > Expr_Value (HB1))
4202 or else
4203 (Expr_Value (LB2) <= Expr_Value (LB1)
4204 and then
4205 Expr_Value (HB1) <= Expr_Value (HB2));
4206 end if;
4207 end;
4208 end if;
4209
4210 elsif Is_Access_Type (T1) then
4211 return not Is_Constrained (T2)
4212 or else Subtypes_Statically_Match
4213 (Designated_Type (T1), Designated_Type (T2));
4214
4215 else
4216 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4217 or else Subtypes_Statically_Match (T1, T2);
4218 end if;
4219 end Subtypes_Statically_Compatible;
4220
4221 -------------------------------
4222 -- Subtypes_Statically_Match --
4223 -------------------------------
4224
4225 -- Subtypes statically match if they have statically matching constraints
4226 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4227 -- they are the same identical constraint, or if they are static and the
4228 -- values match (RM 4.9.1(1)).
4229
4230 function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
4231 begin
4232 -- A type always statically matches itself
4233
4234 if T1 = T2 then
4235 return True;
4236
4237 -- Scalar types
4238
4239 elsif Is_Scalar_Type (T1) then
4240
4241 -- Base types must be the same
4242
4243 if Base_Type (T1) /= Base_Type (T2) then
4244 return False;
4245 end if;
4246
4247 -- A constrained numeric subtype never matches an unconstrained
4248 -- subtype, i.e. both types must be constrained or unconstrained.
4249
4250 -- To understand the requirement for this test, see RM 4.9.1(1).
4251 -- As is made clear in RM 3.5.4(11), type Integer, for example
4252 -- is a constrained subtype with constraint bounds matching the
f3d57416 4253 -- bounds of its corresponding unconstrained base type. In this
996ae0b0
RK
4254 -- situation, Integer and Integer'Base do not statically match,
4255 -- even though they have the same bounds.
4256
4257 -- We only apply this test to types in Standard and types that
4258 -- appear in user programs. That way, we do not have to be
4259 -- too careful about setting Is_Constrained right for itypes.
4260
4261 if Is_Numeric_Type (T1)
4262 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4263 and then (Scope (T1) = Standard_Standard
4264 or else Comes_From_Source (T1))
4265 and then (Scope (T2) = Standard_Standard
4266 or else Comes_From_Source (T2))
4267 then
4268 return False;
82c80734
RD
4269
4270 -- A generic scalar type does not statically match its base
4271 -- type (AI-311). In this case we make sure that the formals,
4272 -- which are first subtypes of their bases, are constrained.
4273
4274 elsif Is_Generic_Type (T1)
4275 and then Is_Generic_Type (T2)
4276 and then (Is_Constrained (T1) /= Is_Constrained (T2))
4277 then
4278 return False;
996ae0b0
RK
4279 end if;
4280
4281 -- If there was an error in either range, then just assume
4282 -- the types statically match to avoid further junk errors
4283
4284 if Error_Posted (Scalar_Range (T1))
4285 or else
4286 Error_Posted (Scalar_Range (T2))
4287 then
4288 return True;
4289 end if;
4290
4291 -- Otherwise both types have bound that can be compared
4292
4293 declare
4294 LB1 : constant Node_Id := Type_Low_Bound (T1);
4295 HB1 : constant Node_Id := Type_High_Bound (T1);
4296 LB2 : constant Node_Id := Type_Low_Bound (T2);
4297 HB2 : constant Node_Id := Type_High_Bound (T2);
4298
4299 begin
4300 -- If the bounds are the same tree node, then match
4301
4302 if LB1 = LB2 and then HB1 = HB2 then
4303 return True;
4304
4305 -- Otherwise bounds must be static and identical value
4306
4307 else
4308 if not Is_Static_Subtype (T1)
4309 or else not Is_Static_Subtype (T2)
4310 then
4311 return False;
4312
4313 -- If either type has constraint error bounds, then say
4314 -- that they match to avoid junk cascaded errors here.
4315
4316 elsif not Is_OK_Static_Subtype (T1)
4317 or else not Is_OK_Static_Subtype (T2)
4318 then
4319 return True;
4320
4321 elsif Is_Real_Type (T1) then
4322 return
4323 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4324 and then
4325 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4326
4327 else
4328 return
4329 Expr_Value (LB1) = Expr_Value (LB2)
4330 and then
4331 Expr_Value (HB1) = Expr_Value (HB2);
4332 end if;
4333 end if;
4334 end;
4335
4336 -- Type with discriminants
4337
4338 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
6eaf4095 4339
c2bf339e
GD
4340 -- Because of view exchanges in multiple instantiations, conformance
4341 -- checking might try to match a partial view of a type with no
4342 -- discriminants with a full view that has defaulted discriminants.
4343 -- In such a case, use the discriminant constraint of the full view,
4344 -- which must exist because we know that the two subtypes have the
4345 -- same base type.
6eaf4095 4346
996ae0b0 4347 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
c2bf339e
GD
4348 if In_Instance then
4349 if Is_Private_Type (T2)
4350 and then Present (Full_View (T2))
4351 and then Has_Discriminants (Full_View (T2))
4352 then
4353 return Subtypes_Statically_Match (T1, Full_View (T2));
4354
4355 elsif Is_Private_Type (T1)
4356 and then Present (Full_View (T1))
4357 and then Has_Discriminants (Full_View (T1))
4358 then
4359 return Subtypes_Statically_Match (Full_View (T1), T2);
4360
4361 else
4362 return False;
4363 end if;
6eaf4095
ES
4364 else
4365 return False;
4366 end if;
996ae0b0
RK
4367 end if;
4368
4369 declare
4370 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
4371 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
4372
13f34a3f
RD
4373 DA1 : Elmt_Id;
4374 DA2 : Elmt_Id;
996ae0b0
RK
4375
4376 begin
4377 if DL1 = DL2 then
4378 return True;
996ae0b0
RK
4379 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
4380 return False;
4381 end if;
4382
13f34a3f 4383 -- Now loop through the discriminant constraints
996ae0b0 4384
13f34a3f
RD
4385 -- Note: the guard here seems necessary, since it is possible at
4386 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
996ae0b0 4387
13f34a3f
RD
4388 if Present (DL1) and then Present (DL2) then
4389 DA1 := First_Elmt (DL1);
4390 DA2 := First_Elmt (DL2);
4391 while Present (DA1) loop
4392 declare
4393 Expr1 : constant Node_Id := Node (DA1);
4394 Expr2 : constant Node_Id := Node (DA2);
996ae0b0 4395
13f34a3f
RD
4396 begin
4397 if not Is_Static_Expression (Expr1)
4398 or else not Is_Static_Expression (Expr2)
4399 then
4400 return False;
996ae0b0 4401
13f34a3f
RD
4402 -- If either expression raised a constraint error,
4403 -- consider the expressions as matching, since this
4404 -- helps to prevent cascading errors.
4405
4406 elsif Raises_Constraint_Error (Expr1)
4407 or else Raises_Constraint_Error (Expr2)
4408 then
4409 null;
4410
4411 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
4412 return False;
4413 end if;
4414 end;
996ae0b0 4415
13f34a3f
RD
4416 Next_Elmt (DA1);
4417 Next_Elmt (DA2);
4418 end loop;
4419 end if;
996ae0b0
RK
4420 end;
4421
4422 return True;
4423
82c80734 4424 -- A definite type does not match an indefinite or classwide type
0356699b
RD
4425 -- However, a generic type with unknown discriminants may be
4426 -- instantiated with a type with no discriminants, and conformance
4427 -- checking on an inherited operation may compare the actual with
4428 -- the subtype that renames it in the instance.
996ae0b0
RK
4429
4430 elsif
4431 Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
4432 then
7a3f77d2
AC
4433 return
4434 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
996ae0b0
RK
4435
4436 -- Array type
4437
4438 elsif Is_Array_Type (T1) then
4439
4440 -- If either subtype is unconstrained then both must be,
4441 -- and if both are unconstrained then no further checking
4442 -- is needed.
4443
4444 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
4445 return not (Is_Constrained (T1) or else Is_Constrained (T2));
4446 end if;
4447
4448 -- Both subtypes are constrained, so check that the index
4449 -- subtypes statically match.
4450
4451 declare
4452 Index1 : Node_Id := First_Index (T1);
4453 Index2 : Node_Id := First_Index (T2);
4454
4455 begin
4456 while Present (Index1) loop
4457 if not
4458 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
4459 then
4460 return False;
4461 end if;
4462
4463 Next_Index (Index1);
4464 Next_Index (Index2);
4465 end loop;
4466
4467 return True;
4468 end;
4469
4470 elsif Is_Access_Type (T1) then
b5bd964f
ES
4471 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
4472 return False;
4473
7a3f77d2
AC
4474 elsif Ekind (T1) = E_Access_Subprogram_Type
4475 or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type
4476 then
b5bd964f
ES
4477 return
4478 Subtype_Conformant
4479 (Designated_Type (T1),
bb98fe75 4480 Designated_Type (T2));
b5bd964f
ES
4481 else
4482 return
4483 Subtypes_Statically_Match
4484 (Designated_Type (T1),
4485 Designated_Type (T2))
4486 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
4487 end if;
996ae0b0
RK
4488
4489 -- All other types definitely match
4490
4491 else
4492 return True;
4493 end if;
4494 end Subtypes_Statically_Match;
4495
4496 ----------
4497 -- Test --
4498 ----------
4499
4500 function Test (Cond : Boolean) return Uint is
4501 begin
4502 if Cond then
4503 return Uint_1;
4504 else
4505 return Uint_0;
4506 end if;
4507 end Test;
4508
4509 ---------------------------------
4510 -- Test_Expression_Is_Foldable --
4511 ---------------------------------
4512
4513 -- One operand case
4514
4515 procedure Test_Expression_Is_Foldable
4516 (N : Node_Id;
4517 Op1 : Node_Id;
4518 Stat : out Boolean;
4519 Fold : out Boolean)
4520 is
4521 begin
4522 Stat := False;
0356699b
RD
4523 Fold := False;
4524
4525 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4526 return;
4527 end if;
996ae0b0
RK
4528
4529 -- If operand is Any_Type, just propagate to result and do not
4530 -- try to fold, this prevents cascaded errors.
4531
4532 if Etype (Op1) = Any_Type then
4533 Set_Etype (N, Any_Type);
996ae0b0
RK
4534 return;
4535
4536 -- If operand raises constraint error, then replace node N with the
4537 -- raise constraint error node, and we are obviously not foldable.
4538 -- Note that this replacement inherits the Is_Static_Expression flag
4539 -- from the operand.
4540
4541 elsif Raises_Constraint_Error (Op1) then
4542 Rewrite_In_Raise_CE (N, Op1);
996ae0b0
RK
4543 return;
4544
4545 -- If the operand is not static, then the result is not static, and
4546 -- all we have to do is to check the operand since it is now known
4547 -- to appear in a non-static context.
4548
4549 elsif not Is_Static_Expression (Op1) then
4550 Check_Non_Static_Context (Op1);
4551 Fold := Compile_Time_Known_Value (Op1);
4552 return;
4553
4554 -- An expression of a formal modular type is not foldable because
4555 -- the modulus is unknown.
4556
4557 elsif Is_Modular_Integer_Type (Etype (Op1))
4558 and then Is_Generic_Type (Etype (Op1))
4559 then
4560 Check_Non_Static_Context (Op1);
996ae0b0
RK
4561 return;
4562
4563 -- Here we have the case of an operand whose type is OK, which is
4564 -- static, and which does not raise constraint error, we can fold.
4565
4566 else
4567 Set_Is_Static_Expression (N);
4568 Fold := True;
4569 Stat := True;
4570 end if;
4571 end Test_Expression_Is_Foldable;
4572
4573 -- Two operand case
4574
4575 procedure Test_Expression_Is_Foldable
4576 (N : Node_Id;
4577 Op1 : Node_Id;
4578 Op2 : Node_Id;
4579 Stat : out Boolean;
4580 Fold : out Boolean)
4581 is
4582 Rstat : constant Boolean := Is_Static_Expression (Op1)
4583 and then Is_Static_Expression (Op2);
4584
4585 begin
4586 Stat := False;
0356699b
RD
4587 Fold := False;
4588
4589 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4590 return;
4591 end if;
996ae0b0
RK
4592
4593 -- If either operand is Any_Type, just propagate to result and
4594 -- do not try to fold, this prevents cascaded errors.
4595
4596 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
4597 Set_Etype (N, Any_Type);
996ae0b0
RK
4598 return;
4599
4600 -- If left operand raises constraint error, then replace node N with
4601 -- the raise constraint error node, and we are obviously not foldable.
4602 -- Is_Static_Expression is set from the two operands in the normal way,
4603 -- and we check the right operand if it is in a non-static context.
4604
4605 elsif Raises_Constraint_Error (Op1) then
4606 if not Rstat then
4607 Check_Non_Static_Context (Op2);
4608 end if;
4609
4610 Rewrite_In_Raise_CE (N, Op1);
4611 Set_Is_Static_Expression (N, Rstat);
996ae0b0
RK
4612 return;
4613
4614 -- Similar processing for the case of the right operand. Note that
4615 -- we don't use this routine for the short-circuit case, so we do
4616 -- not have to worry about that special case here.
4617
4618 elsif Raises_Constraint_Error (Op2) then
4619 if not Rstat then
4620 Check_Non_Static_Context (Op1);
4621 end if;
4622
4623 Rewrite_In_Raise_CE (N, Op2);
4624 Set_Is_Static_Expression (N, Rstat);
996ae0b0
RK
4625 return;
4626
82c80734 4627 -- Exclude expressions of a generic modular type, as above
996ae0b0
RK
4628
4629 elsif Is_Modular_Integer_Type (Etype (Op1))
4630 and then Is_Generic_Type (Etype (Op1))
4631 then
4632 Check_Non_Static_Context (Op1);
996ae0b0
RK
4633 return;
4634
4635 -- If result is not static, then check non-static contexts on operands
4636 -- since one of them may be static and the other one may not be static
4637
4638 elsif not Rstat then
4639 Check_Non_Static_Context (Op1);
4640 Check_Non_Static_Context (Op2);
4641 Fold := Compile_Time_Known_Value (Op1)
4642 and then Compile_Time_Known_Value (Op2);
4643 return;
4644
4645 -- Else result is static and foldable. Both operands are static,
4646 -- and neither raises constraint error, so we can definitely fold.
4647
4648 else
4649 Set_Is_Static_Expression (N);
4650 Fold := True;
4651 Stat := True;
4652 return;
4653 end if;
4654 end Test_Expression_Is_Foldable;
4655
4656 --------------
4657 -- To_Bits --
4658 --------------
4659
4660 procedure To_Bits (U : Uint; B : out Bits) is
4661 begin
4662 for J in 0 .. B'Last loop
4663 B (J) := (U / (2 ** J)) mod 2 /= 0;
4664 end loop;
4665 end To_Bits;
4666
fbf5a39b
AC
4667 --------------------
4668 -- Why_Not_Static --
4669 --------------------
4670
4671 procedure Why_Not_Static (Expr : Node_Id) is
4672 N : constant Node_Id := Original_Node (Expr);
4673 Typ : Entity_Id;
4674 E : Entity_Id;
4675
4676 procedure Why_Not_Static_List (L : List_Id);
4677 -- A version that can be called on a list of expressions. Finds
4678 -- all non-static violations in any element of the list.
4679
4680 -------------------------
4681 -- Why_Not_Static_List --
4682 -------------------------
4683
4684 procedure Why_Not_Static_List (L : List_Id) is
4685 N : Node_Id;
4686
4687 begin
4688 if Is_Non_Empty_List (L) then
4689 N := First (L);
4690 while Present (N) loop
4691 Why_Not_Static (N);
4692 Next (N);
4693 end loop;
4694 end if;
4695 end Why_Not_Static_List;
4696
4697 -- Start of processing for Why_Not_Static
4698
4699 begin
4700 -- If in ACATS mode (debug flag 2), then suppress all these
4701 -- messages, this avoids massive updates to the ACATS base line.
4702
4703 if Debug_Flag_2 then
4704 return;
4705 end if;
4706
4707 -- Ignore call on error or empty node
4708
4709 if No (Expr) or else Nkind (Expr) = N_Error then
4710 return;
4711 end if;
4712
4713 -- Preprocessing for sub expressions
4714
4715 if Nkind (Expr) in N_Subexpr then
4716
4717 -- Nothing to do if expression is static
4718
4719 if Is_OK_Static_Expression (Expr) then
4720 return;
4721 end if;
4722
4723 -- Test for constraint error raised
4724
4725 if Raises_Constraint_Error (Expr) then
4726 Error_Msg_N
4727 ("expression raises exception, cannot be static " &
b11e8d6f 4728 "(RM 4.9(34))!", N);
fbf5a39b
AC
4729 return;
4730 end if;
4731
4732 -- If no type, then something is pretty wrong, so ignore
4733
4734 Typ := Etype (Expr);
4735
4736 if No (Typ) then
4737 return;
4738 end if;
4739
4740 -- Type must be scalar or string type
4741
4742 if not Is_Scalar_Type (Typ)
4743 and then not Is_String_Type (Typ)
4744 then
4745 Error_Msg_N
4746 ("static expression must have scalar or string type " &
b11e8d6f 4747 "(RM 4.9(2))!", N);
fbf5a39b
AC
4748 return;
4749 end if;
4750 end if;
4751
4752 -- If we got through those checks, test particular node kind
4753
4754 case Nkind (N) is
4755 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
4756 E := Entity (N);
4757
4758 if Is_Named_Number (E) then
4759 null;
4760
4761 elsif Ekind (E) = E_Constant then
4762 if not Is_Static_Expression (Constant_Value (E)) then
4763 Error_Msg_NE
b11e8d6f 4764 ("& is not a static constant (RM 4.9(5))!", N, E);
fbf5a39b
AC
4765 end if;
4766
4767 else
4768 Error_Msg_NE
4769 ("& is not static constant or named number " &
b11e8d6f 4770 "(RM 4.9(5))!", N, E);
fbf5a39b
AC
4771 end if;
4772
29797f34 4773 when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
fbf5a39b
AC
4774 if Nkind (N) in N_Op_Shift then
4775 Error_Msg_N
b11e8d6f 4776 ("shift functions are never static (RM 4.9(6,18))!", N);
fbf5a39b
AC
4777
4778 else
4779 Why_Not_Static (Left_Opnd (N));
4780 Why_Not_Static (Right_Opnd (N));
4781 end if;
4782
4783 when N_Unary_Op =>
4784 Why_Not_Static (Right_Opnd (N));
4785
4786 when N_Attribute_Reference =>
4787 Why_Not_Static_List (Expressions (N));
4788
4789 E := Etype (Prefix (N));
4790
4791 if E = Standard_Void_Type then
4792 return;
4793 end if;
4794
4795 -- Special case non-scalar'Size since this is a common error
4796
4797 if Attribute_Name (N) = Name_Size then
4798 Error_Msg_N
4799 ("size attribute is only static for scalar type " &
b11e8d6f 4800 "(RM 4.9(7,8))", N);
fbf5a39b
AC
4801
4802 -- Flag array cases
4803
4804 elsif Is_Array_Type (E) then
4805 if Attribute_Name (N) /= Name_First
4806 and then
4807 Attribute_Name (N) /= Name_Last
4808 and then
4809 Attribute_Name (N) /= Name_Length
4810 then
4811 Error_Msg_N
4812 ("static array attribute must be Length, First, or Last " &
b11e8d6f 4813 "(RM 4.9(8))!", N);
fbf5a39b
AC
4814
4815 -- Since we know the expression is not-static (we already
4816 -- tested for this, must mean array is not static).
4817
4818 else
4819 Error_Msg_N
b11e8d6f 4820 ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
fbf5a39b
AC
4821 end if;
4822
4823 return;
4824
4825 -- Special case generic types, since again this is a common
4826 -- source of confusion.
4827
4828 elsif Is_Generic_Actual_Type (E)
4829 or else
4830 Is_Generic_Type (E)
4831 then
4832 Error_Msg_N
4833 ("attribute of generic type is never static " &
b11e8d6f 4834 "(RM 4.9(7,8))!", N);
fbf5a39b
AC
4835
4836 elsif Is_Static_Subtype (E) then
4837 null;
4838
4839 elsif Is_Scalar_Type (E) then
4840 Error_Msg_N
4841 ("prefix type for attribute is not static scalar subtype " &
b11e8d6f 4842 "(RM 4.9(7))!", N);
fbf5a39b
AC
4843
4844 else
4845 Error_Msg_N
4846 ("static attribute must apply to array/scalar type " &
b11e8d6f 4847 "(RM 4.9(7,8))!", N);
fbf5a39b
AC
4848 end if;
4849
4850 when N_String_Literal =>
4851 Error_Msg_N
b11e8d6f 4852 ("subtype of string literal is non-static (RM 4.9(4))!", N);
fbf5a39b
AC
4853
4854 when N_Explicit_Dereference =>
4855 Error_Msg_N
b11e8d6f 4856 ("explicit dereference is never static (RM 4.9)!", N);
fbf5a39b
AC
4857
4858 when N_Function_Call =>
4859 Why_Not_Static_List (Parameter_Associations (N));
b11e8d6f 4860 Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
fbf5a39b
AC
4861
4862 when N_Parameter_Association =>
4863 Why_Not_Static (Explicit_Actual_Parameter (N));
4864
4865 when N_Indexed_Component =>
4866 Error_Msg_N
b11e8d6f 4867 ("indexed component is never static (RM 4.9)!", N);
fbf5a39b
AC
4868
4869 when N_Procedure_Call_Statement =>
4870 Error_Msg_N
b11e8d6f 4871 ("procedure call is never static (RM 4.9)!", N);
fbf5a39b
AC
4872
4873 when N_Qualified_Expression =>
4874 Why_Not_Static (Expression (N));
4875
4876 when N_Aggregate | N_Extension_Aggregate =>
4877 Error_Msg_N
b11e8d6f 4878 ("an aggregate is never static (RM 4.9)!", N);
fbf5a39b
AC
4879
4880 when N_Range =>
4881 Why_Not_Static (Low_Bound (N));
4882 Why_Not_Static (High_Bound (N));
4883
4884 when N_Range_Constraint =>
4885 Why_Not_Static (Range_Expression (N));
4886
4887 when N_Subtype_Indication =>
4888 Why_Not_Static (Constraint (N));
4889
4890 when N_Selected_Component =>
4891 Error_Msg_N
b11e8d6f 4892 ("selected component is never static (RM 4.9)!", N);
fbf5a39b
AC
4893
4894 when N_Slice =>
4895 Error_Msg_N
b11e8d6f 4896 ("slice is never static (RM 4.9)!", N);
fbf5a39b
AC
4897
4898 when N_Type_Conversion =>
4899 Why_Not_Static (Expression (N));
4900
4901 if not Is_Scalar_Type (Etype (Prefix (N)))
4902 or else not Is_Static_Subtype (Etype (Prefix (N)))
4903 then
4904 Error_Msg_N
4905 ("static conversion requires static scalar subtype result " &
b11e8d6f 4906 "(RM 4.9(9))!", N);
fbf5a39b
AC
4907 end if;
4908
4909 when N_Unchecked_Type_Conversion =>
4910 Error_Msg_N
b11e8d6f 4911 ("unchecked type conversion is never static (RM 4.9)!", N);
fbf5a39b
AC
4912
4913 when others =>
4914 null;
4915
4916 end case;
4917 end Why_Not_Static;
4918
996ae0b0 4919end Sem_Eval;