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