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