OSDN Git Service

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