OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_eval.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.