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       -- To_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 (Kind = N_Or_Else and Is_True (Left_Int))
2909       then
2910          Fold_Uint (N, Left_Int, Rstat);
2911          return;
2912       end if;
2913
2914       --  If first operand not decisive, then it does matter if the right
2915       --  operand raises constraint error, since it will be evaluated, so
2916       --  we simply replace the node with the right operand. Note that this
2917       --  properly propagates Is_Static_Expression and Raises_Constraint_Error
2918       --  (both are set to True in Right).
2919
2920       if Raises_Constraint_Error (Right) then
2921          Rewrite_In_Raise_CE (N, Right);
2922          Check_Non_Static_Context (Left);
2923          return;
2924       end if;
2925
2926       --  Otherwise the result depends on the right operand
2927
2928       Fold_Uint (N, Expr_Value (Right), Rstat);
2929       return;
2930    end Eval_Short_Circuit;
2931
2932    ----------------
2933    -- Eval_Slice --
2934    ----------------
2935
2936    --  Slices can never be static, so the only processing required is to
2937    --  check for non-static context if an explicit range is given.
2938
2939    procedure Eval_Slice (N : Node_Id) is
2940       Drange : constant Node_Id := Discrete_Range (N);
2941    begin
2942       if Nkind (Drange) = N_Range then
2943          Check_Non_Static_Context (Low_Bound (Drange));
2944          Check_Non_Static_Context (High_Bound (Drange));
2945       end if;
2946
2947       --  A slice of the form  A (subtype), when the subtype is the index of
2948       --  the type of A, is redundant, the slice can be replaced with A, and
2949       --  this is worth a warning.
2950
2951       if Is_Entity_Name (Prefix (N)) then
2952          declare
2953             E : constant Entity_Id := Entity (Prefix (N));
2954             T : constant Entity_Id := Etype (E);
2955          begin
2956             if Ekind (E) = E_Constant
2957               and then Is_Array_Type (T)
2958               and then Is_Entity_Name (Drange)
2959             then
2960                if Is_Entity_Name (Original_Node (First_Index (T)))
2961                  and then Entity (Original_Node (First_Index (T)))
2962                     = Entity (Drange)
2963                then
2964                   if Warn_On_Redundant_Constructs then
2965                      Error_Msg_N ("redundant slice denotes whole array?", N);
2966                   end if;
2967
2968                   --  The following might be a useful optimization ????
2969
2970                   --  Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
2971                end if;
2972             end if;
2973          end;
2974       end if;
2975    end Eval_Slice;
2976
2977    -------------------------
2978    -- Eval_String_Literal --
2979    -------------------------
2980
2981    procedure Eval_String_Literal (N : Node_Id) is
2982       Typ : constant Entity_Id := Etype (N);
2983       Bas : constant Entity_Id := Base_Type (Typ);
2984       Xtp : Entity_Id;
2985       Len : Nat;
2986       Lo  : Node_Id;
2987
2988    begin
2989       --  Nothing to do if error type (handles cases like default expressions
2990       --  or generics where we have not yet fully resolved the type)
2991
2992       if Bas = Any_Type or else Bas = Any_String then
2993          return;
2994       end if;
2995
2996       --  String literals are static if the subtype is static (RM 4.9(2)), so
2997       --  reset the static expression flag (it was set unconditionally in
2998       --  Analyze_String_Literal) if the subtype is non-static. We tell if
2999       --  the subtype is static by looking at the lower bound.
3000
3001       if Ekind (Typ) = E_String_Literal_Subtype then
3002          if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3003             Set_Is_Static_Expression (N, False);
3004             return;
3005          end if;
3006
3007       --  Here if Etype of string literal is normal Etype (not yet possible,
3008       --  but may be possible in future!)
3009
3010       elsif not Is_OK_Static_Expression
3011                     (Type_Low_Bound (Etype (First_Index (Typ))))
3012       then
3013          Set_Is_Static_Expression (N, False);
3014          return;
3015       end if;
3016
3017       --  If original node was a type conversion, then result if non-static
3018
3019       if Nkind (Original_Node (N)) = N_Type_Conversion then
3020          Set_Is_Static_Expression (N, False);
3021          return;
3022       end if;
3023
3024       --  Test for illegal Ada 95 cases. A string literal is illegal in
3025       --  Ada 95 if its bounds are outside the index base type and this
3026       --  index type is static. This can happen in only two ways. Either
3027       --  the string literal is too long, or it is null, and the lower
3028       --  bound is type'First. In either case it is the upper bound that
3029       --  is out of range of the index type.
3030
3031       if Ada_Version >= Ada_95 then
3032          if Root_Type (Bas) = Standard_String
3033               or else
3034             Root_Type (Bas) = Standard_Wide_String
3035          then
3036             Xtp := Standard_Positive;
3037          else
3038             Xtp := Etype (First_Index (Bas));
3039          end if;
3040
3041          if Ekind (Typ) = E_String_Literal_Subtype then
3042             Lo := String_Literal_Low_Bound (Typ);
3043          else
3044             Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3045          end if;
3046
3047          Len := String_Length (Strval (N));
3048
3049          if UI_From_Int (Len) > String_Type_Len (Bas) then
3050             Apply_Compile_Time_Constraint_Error
3051               (N, "string literal too long for}", CE_Length_Check_Failed,
3052                Ent => Bas,
3053                Typ => First_Subtype (Bas));
3054
3055          elsif Len = 0
3056            and then not Is_Generic_Type (Xtp)
3057            and then
3058              Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3059          then
3060             Apply_Compile_Time_Constraint_Error
3061               (N, "null string literal not allowed for}",
3062                CE_Length_Check_Failed,
3063                Ent => Bas,
3064                Typ => First_Subtype (Bas));
3065          end if;
3066       end if;
3067    end Eval_String_Literal;
3068
3069    --------------------------
3070    -- Eval_Type_Conversion --
3071    --------------------------
3072
3073    --  A type conversion is potentially static if its subtype mark is for a
3074    --  static scalar subtype, and its operand expression is potentially static
3075    --  (RM 4.9 (10))
3076
3077    procedure Eval_Type_Conversion (N : Node_Id) is
3078       Operand     : constant Node_Id   := Expression (N);
3079       Source_Type : constant Entity_Id := Etype (Operand);
3080       Target_Type : constant Entity_Id := Etype (N);
3081
3082       Stat   : Boolean;
3083       Fold   : Boolean;
3084
3085       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3086       --  Returns true if type T is an integer type, or if it is a
3087       --  fixed-point type to be treated as an integer (i.e. the flag
3088       --  Conversion_OK is set on the conversion node).
3089
3090       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3091       --  Returns true if type T is a floating-point type, or if it is a
3092       --  fixed-point type that is not to be treated as an integer (i.e. the
3093       --  flag Conversion_OK is not set on the conversion node).
3094
3095       ------------------------------
3096       -- To_Be_Treated_As_Integer --
3097       ------------------------------
3098
3099       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3100       begin
3101          return
3102            Is_Integer_Type (T)
3103              or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3104       end To_Be_Treated_As_Integer;
3105
3106       ---------------------------
3107       -- To_Be_Treated_As_Real --
3108       ---------------------------
3109
3110       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3111       begin
3112          return
3113            Is_Floating_Point_Type (T)
3114              or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3115       end To_Be_Treated_As_Real;
3116
3117    --  Start of processing for Eval_Type_Conversion
3118
3119    begin
3120       --  Cannot fold if target type is non-static or if semantic error
3121
3122       if not Is_Static_Subtype (Target_Type) then
3123          Check_Non_Static_Context (Operand);
3124          return;
3125
3126       elsif Error_Posted (N) then
3127          return;
3128       end if;
3129
3130       --  If not foldable we are done
3131
3132       Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3133
3134       if not Fold then
3135          return;
3136
3137       --  Don't try fold if target type has constraint error bounds
3138
3139       elsif not Is_OK_Static_Subtype (Target_Type) then
3140          Set_Raises_Constraint_Error (N);
3141          return;
3142       end if;
3143
3144       --  Remaining processing depends on operand types. Note that in the
3145       --  following type test, fixed-point counts as real unless the flag
3146       --  Conversion_OK is set, in which case it counts as integer.
3147
3148       --  Fold conversion, case of string type. The result is not static
3149
3150       if Is_String_Type (Target_Type) then
3151          Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3152
3153          return;
3154
3155       --  Fold conversion, case of integer target type
3156
3157       elsif To_Be_Treated_As_Integer (Target_Type) then
3158          declare
3159             Result : Uint;
3160
3161          begin
3162             --  Integer to integer conversion
3163
3164             if To_Be_Treated_As_Integer (Source_Type) then
3165                Result := Expr_Value (Operand);
3166
3167             --  Real to integer conversion
3168
3169             else
3170                Result := UR_To_Uint (Expr_Value_R (Operand));
3171             end if;
3172
3173             --  If fixed-point type (Conversion_OK must be set), then the
3174             --  result is logically an integer, but we must replace the
3175             --  conversion with the corresponding real literal, since the
3176             --  type from a semantic point of view is still fixed-point.
3177
3178             if Is_Fixed_Point_Type (Target_Type) then
3179                Fold_Ureal
3180                  (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3181
3182             --  Otherwise result is integer literal
3183
3184             else
3185                Fold_Uint (N, Result, Stat);
3186             end if;
3187          end;
3188
3189       --  Fold conversion, case of real target type
3190
3191       elsif To_Be_Treated_As_Real (Target_Type) then
3192          declare
3193             Result : Ureal;
3194
3195          begin
3196             if To_Be_Treated_As_Real (Source_Type) then
3197                Result := Expr_Value_R (Operand);
3198             else
3199                Result := UR_From_Uint (Expr_Value (Operand));
3200             end if;
3201
3202             Fold_Ureal (N, Result, Stat);
3203          end;
3204
3205       --  Enumeration types
3206
3207       else
3208          Fold_Uint (N, Expr_Value (Operand), Stat);
3209       end if;
3210
3211       if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3212          Out_Of_Range (N);
3213       end if;
3214
3215    end Eval_Type_Conversion;
3216
3217    -------------------
3218    -- Eval_Unary_Op --
3219    -------------------
3220
3221    --  Predefined unary operators are static functions (RM 4.9(20)) and thus
3222    --  are potentially static if the operand is potentially static (RM 4.9(7))
3223
3224    procedure Eval_Unary_Op (N : Node_Id) is
3225       Right : constant Node_Id := Right_Opnd (N);
3226       Stat  : Boolean;
3227       Fold  : Boolean;
3228
3229    begin
3230       --  If not foldable we are done
3231
3232       Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3233
3234       if not Fold then
3235          return;
3236       end if;
3237
3238       --  Fold for integer case
3239
3240       if Is_Integer_Type (Etype (N)) then
3241          declare
3242             Rint   : constant Uint := Expr_Value (Right);
3243             Result : Uint;
3244
3245          begin
3246             --  In the case of modular unary plus and abs there is no need
3247             --  to adjust the result of the operation since if the original
3248             --  operand was in bounds the result will be in the bounds of the
3249             --  modular type. However, in the case of modular unary minus the
3250             --  result may go out of the bounds of the modular type and needs
3251             --  adjustment.
3252
3253             if Nkind (N) = N_Op_Plus then
3254                Result := Rint;
3255
3256             elsif Nkind (N) = N_Op_Minus then
3257                if Is_Modular_Integer_Type (Etype (N)) then
3258                   Result := (-Rint) mod Modulus (Etype (N));
3259                else
3260                   Result := (-Rint);
3261                end if;
3262
3263             else
3264                pragma Assert (Nkind (N) = N_Op_Abs);
3265                Result := abs Rint;
3266             end if;
3267
3268             Fold_Uint (N, Result, Stat);
3269          end;
3270
3271       --  Fold for real case
3272
3273       elsif Is_Real_Type (Etype (N)) then
3274          declare
3275             Rreal  : constant Ureal := Expr_Value_R (Right);
3276             Result : Ureal;
3277
3278          begin
3279             if Nkind (N) = N_Op_Plus then
3280                Result := Rreal;
3281
3282             elsif Nkind (N) = N_Op_Minus then
3283                Result := UR_Negate (Rreal);
3284
3285             else
3286                pragma Assert (Nkind (N) = N_Op_Abs);
3287                Result := abs Rreal;
3288             end if;
3289
3290             Fold_Ureal (N, Result, Stat);
3291          end;
3292       end if;
3293    end Eval_Unary_Op;
3294
3295    -------------------------------
3296    -- Eval_Unchecked_Conversion --
3297    -------------------------------
3298
3299    --  Unchecked conversions can never be static, so the only required
3300    --  processing is to check for a non-static context for the operand.
3301
3302    procedure Eval_Unchecked_Conversion (N : Node_Id) is
3303    begin
3304       Check_Non_Static_Context (Expression (N));
3305    end Eval_Unchecked_Conversion;
3306
3307    --------------------
3308    -- Expr_Rep_Value --
3309    --------------------
3310
3311    function Expr_Rep_Value (N : Node_Id) return Uint is
3312       Kind : constant Node_Kind := Nkind (N);
3313       Ent  : Entity_Id;
3314
3315    begin
3316       if Is_Entity_Name (N) then
3317          Ent := Entity (N);
3318
3319          --  An enumeration literal that was either in the source or
3320          --  created as a result of static evaluation.
3321
3322          if Ekind (Ent) = E_Enumeration_Literal then
3323             return Enumeration_Rep (Ent);
3324
3325          --  A user defined static constant
3326
3327          else
3328             pragma Assert (Ekind (Ent) = E_Constant);
3329             return Expr_Rep_Value (Constant_Value (Ent));
3330          end if;
3331
3332       --  An integer literal that was either in the source or created
3333       --  as a result of static evaluation.
3334
3335       elsif Kind = N_Integer_Literal then
3336          return Intval (N);
3337
3338       --  A real literal for a fixed-point type. This must be the fixed-point
3339       --  case, either the literal is of a fixed-point type, or it is a bound
3340       --  of a fixed-point type, with type universal real. In either case we
3341       --  obtain the desired value from Corresponding_Integer_Value.
3342
3343       elsif Kind = N_Real_Literal then
3344          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3345          return Corresponding_Integer_Value (N);
3346
3347       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3348
3349       elsif Kind = N_Attribute_Reference
3350         and then Attribute_Name (N) = Name_Null_Parameter
3351       then
3352          return Uint_0;
3353
3354       --  Otherwise must be character literal
3355
3356       else
3357          pragma Assert (Kind = N_Character_Literal);
3358          Ent := Entity (N);
3359
3360          --  Since Character literals of type Standard.Character don't
3361          --  have any defining character literals built for them, they
3362          --  do not have their Entity set, so just use their Char
3363          --  code. Otherwise for user-defined character literals use
3364          --  their Pos value as usual which is the same as the Rep value.
3365
3366          if No (Ent) then
3367             return Char_Literal_Value (N);
3368          else
3369             return Enumeration_Rep (Ent);
3370          end if;
3371       end if;
3372    end Expr_Rep_Value;
3373
3374    ----------------
3375    -- Expr_Value --
3376    ----------------
3377
3378    function Expr_Value (N : Node_Id) return Uint is
3379       Kind   : constant Node_Kind := Nkind (N);
3380       CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3381       Ent    : Entity_Id;
3382       Val    : Uint;
3383
3384    begin
3385       --  If already in cache, then we know it's compile time known and we can
3386       --  return the value that was previously stored in the cache since
3387       --  compile time known values cannot change.
3388
3389       if CV_Ent.N = N then
3390          return CV_Ent.V;
3391       end if;
3392
3393       --  Otherwise proceed to test value
3394
3395       if Is_Entity_Name (N) then
3396          Ent := Entity (N);
3397
3398          --  An enumeration literal that was either in the source or
3399          --  created as a result of static evaluation.
3400
3401          if Ekind (Ent) = E_Enumeration_Literal then
3402             Val := Enumeration_Pos (Ent);
3403
3404          --  A user defined static constant
3405
3406          else
3407             pragma Assert (Ekind (Ent) = E_Constant);
3408             Val := Expr_Value (Constant_Value (Ent));
3409          end if;
3410
3411       --  An integer literal that was either in the source or created
3412       --  as a result of static evaluation.
3413
3414       elsif Kind = N_Integer_Literal then
3415          Val := Intval (N);
3416
3417       --  A real literal for a fixed-point type. This must be the fixed-point
3418       --  case, either the literal is of a fixed-point type, or it is a bound
3419       --  of a fixed-point type, with type universal real. In either case we
3420       --  obtain the desired value from Corresponding_Integer_Value.
3421
3422       elsif Kind = N_Real_Literal then
3423
3424          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3425          Val := Corresponding_Integer_Value (N);
3426
3427       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3428
3429       elsif Kind = N_Attribute_Reference
3430         and then Attribute_Name (N) = Name_Null_Parameter
3431       then
3432          Val := Uint_0;
3433
3434       --  Otherwise must be character literal
3435
3436       else
3437          pragma Assert (Kind = N_Character_Literal);
3438          Ent := Entity (N);
3439
3440          --  Since Character literals of type Standard.Character don't
3441          --  have any defining character literals built for them, they
3442          --  do not have their Entity set, so just use their Char
3443          --  code. Otherwise for user-defined character literals use
3444          --  their Pos value as usual.
3445
3446          if No (Ent) then
3447             Val := Char_Literal_Value (N);
3448          else
3449             Val := Enumeration_Pos (Ent);
3450          end if;
3451       end if;
3452
3453       --  Come here with Val set to value to be returned, set cache
3454
3455       CV_Ent.N := N;
3456       CV_Ent.V := Val;
3457       return Val;
3458    end Expr_Value;
3459
3460    ------------------
3461    -- Expr_Value_E --
3462    ------------------
3463
3464    function Expr_Value_E (N : Node_Id) return Entity_Id is
3465       Ent  : constant Entity_Id := Entity (N);
3466
3467    begin
3468       if Ekind (Ent) = E_Enumeration_Literal then
3469          return Ent;
3470       else
3471          pragma Assert (Ekind (Ent) = E_Constant);
3472          return Expr_Value_E (Constant_Value (Ent));
3473       end if;
3474    end Expr_Value_E;
3475
3476    ------------------
3477    -- Expr_Value_R --
3478    ------------------
3479
3480    function Expr_Value_R (N : Node_Id) return Ureal is
3481       Kind : constant Node_Kind := Nkind (N);
3482       Ent  : Entity_Id;
3483       Expr : Node_Id;
3484
3485    begin
3486       if Kind = N_Real_Literal then
3487          return Realval (N);
3488
3489       elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3490          Ent := Entity (N);
3491          pragma Assert (Ekind (Ent) = E_Constant);
3492          return Expr_Value_R (Constant_Value (Ent));
3493
3494       elsif Kind = N_Integer_Literal then
3495          return UR_From_Uint (Expr_Value (N));
3496
3497       --  Strange case of VAX literals, which are at this stage transformed
3498       --  into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3499       --  Exp_Vfpt for further details.
3500
3501       elsif Vax_Float (Etype (N))
3502         and then Nkind (N) = N_Unchecked_Type_Conversion
3503       then
3504          Expr := Expression (N);
3505
3506          if Nkind (Expr) = N_Function_Call
3507            and then Present (Parameter_Associations (Expr))
3508          then
3509             Expr := First (Parameter_Associations (Expr));
3510
3511             if Nkind (Expr) = N_Real_Literal then
3512                return Realval (Expr);
3513             end if;
3514          end if;
3515
3516       --  Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3517
3518       elsif Kind = N_Attribute_Reference
3519         and then Attribute_Name (N) = Name_Null_Parameter
3520       then
3521          return Ureal_0;
3522       end if;
3523
3524       --  If we fall through, we have a node that cannot be interpreted
3525       --  as a compile time constant. That is definitely an error.
3526
3527       raise Program_Error;
3528    end Expr_Value_R;
3529
3530    ------------------
3531    -- Expr_Value_S --
3532    ------------------
3533
3534    function Expr_Value_S (N : Node_Id) return Node_Id is
3535    begin
3536       if Nkind (N) = N_String_Literal then
3537          return N;
3538       else
3539          pragma Assert (Ekind (Entity (N)) = E_Constant);
3540          return Expr_Value_S (Constant_Value (Entity (N)));
3541       end if;
3542    end Expr_Value_S;
3543
3544    --------------------------
3545    -- Flag_Non_Static_Expr --
3546    --------------------------
3547
3548    procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
3549    begin
3550       if Error_Posted (Expr) and then not All_Errors_Mode then
3551          return;
3552       else
3553          Error_Msg_F (Msg, Expr);
3554          Why_Not_Static (Expr);
3555       end if;
3556    end Flag_Non_Static_Expr;
3557
3558    --------------
3559    -- Fold_Str --
3560    --------------
3561
3562    procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
3563       Loc : constant Source_Ptr := Sloc (N);
3564       Typ : constant Entity_Id  := Etype (N);
3565
3566    begin
3567       Rewrite (N, Make_String_Literal (Loc, Strval => Val));
3568
3569       --  We now have the literal with the right value, both the actual type
3570       --  and the expected type of this literal are taken from the expression
3571       --  that was evaluated.
3572
3573       Analyze (N);
3574       Set_Is_Static_Expression (N, Static);
3575       Set_Etype (N, Typ);
3576       Resolve (N);
3577    end Fold_Str;
3578
3579    ---------------
3580    -- Fold_Uint --
3581    ---------------
3582
3583    procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
3584       Loc : constant Source_Ptr := Sloc (N);
3585       Typ : Entity_Id  := Etype (N);
3586       Ent : Entity_Id;
3587
3588    begin
3589       --  If we are folding a named number, retain the entity in the
3590       --  literal, for ASIS use.
3591
3592       if Is_Entity_Name (N)
3593         and then Ekind (Entity (N)) = E_Named_Integer
3594       then
3595          Ent := Entity (N);
3596       else
3597          Ent := Empty;
3598       end if;
3599
3600       if Is_Private_Type (Typ) then
3601          Typ := Full_View (Typ);
3602       end if;
3603
3604       --  For a result of type integer, substitute an N_Integer_Literal node
3605       --  for the result of the compile time evaluation of the expression.
3606       --  For ASIS use, set a link to the original named number when not in
3607       --  a generic context.
3608
3609       if Is_Integer_Type (Typ) then
3610          Rewrite (N, Make_Integer_Literal (Loc, Val));
3611
3612          Set_Original_Entity (N, Ent);
3613
3614       --  Otherwise we have an enumeration type, and we substitute either
3615       --  an N_Identifier or N_Character_Literal to represent the enumeration
3616       --  literal corresponding to the given value, which must always be in
3617       --  range, because appropriate tests have already been made for this.
3618
3619       else pragma Assert (Is_Enumeration_Type (Typ));
3620          Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
3621       end if;
3622
3623       --  We now have the literal with the right value, both the actual type
3624       --  and the expected type of this literal are taken from the expression
3625       --  that was evaluated.
3626
3627       Analyze (N);
3628       Set_Is_Static_Expression (N, Static);
3629       Set_Etype (N, Typ);
3630       Resolve (N);
3631    end Fold_Uint;
3632
3633    ----------------
3634    -- Fold_Ureal --
3635    ----------------
3636
3637    procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
3638       Loc : constant Source_Ptr := Sloc (N);
3639       Typ : constant Entity_Id  := Etype (N);
3640       Ent : Entity_Id;
3641
3642    begin
3643       --  If we are folding a named number, retain the entity in the
3644       --  literal, for ASIS use.
3645
3646       if Is_Entity_Name (N)
3647         and then Ekind (Entity (N)) = E_Named_Real
3648       then
3649          Ent := Entity (N);
3650       else
3651          Ent := Empty;
3652       end if;
3653
3654       Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
3655
3656       --  Set link to original named number, for ASIS use
3657
3658       Set_Original_Entity (N, Ent);
3659
3660       --  Both the actual and expected type comes from the original expression
3661
3662       Analyze (N);
3663       Set_Is_Static_Expression (N, Static);
3664       Set_Etype (N, Typ);
3665       Resolve (N);
3666    end Fold_Ureal;
3667
3668    ---------------
3669    -- From_Bits --
3670    ---------------
3671
3672    function From_Bits (B : Bits; T : Entity_Id) return Uint is
3673       V : Uint := Uint_0;
3674
3675    begin
3676       for J in 0 .. B'Last loop
3677          if B (J) then
3678             V := V + 2 ** J;
3679          end if;
3680       end loop;
3681
3682       if Non_Binary_Modulus (T) then
3683          V := V mod Modulus (T);
3684       end if;
3685
3686       return V;
3687    end From_Bits;
3688
3689    --------------------
3690    -- Get_String_Val --
3691    --------------------
3692
3693    function Get_String_Val (N : Node_Id) return Node_Id is
3694    begin
3695       if Nkind (N) = N_String_Literal then
3696          return N;
3697
3698       elsif Nkind (N) = N_Character_Literal then
3699          return N;
3700
3701       else
3702          pragma Assert (Is_Entity_Name (N));
3703          return Get_String_Val (Constant_Value (Entity (N)));
3704       end if;
3705    end Get_String_Val;
3706
3707    ----------------
3708    -- Initialize --
3709    ----------------
3710
3711    procedure Initialize is
3712    begin
3713       CV_Cache := (others => (Node_High_Bound, Uint_0));
3714    end Initialize;
3715
3716    --------------------
3717    -- In_Subrange_Of --
3718    --------------------
3719
3720    function In_Subrange_Of
3721      (T1        : Entity_Id;
3722       T2        : Entity_Id;
3723       Fixed_Int : Boolean := False) return Boolean
3724    is
3725       L1 : Node_Id;
3726       H1 : Node_Id;
3727
3728       L2 : Node_Id;
3729       H2 : Node_Id;
3730
3731    begin
3732       if T1 = T2 or else Is_Subtype_Of (T1, T2) then
3733          return True;
3734
3735       --  Never in range if both types are not scalar. Don't know if this can
3736       --  actually happen, but just in case.
3737
3738       elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
3739          return False;
3740
3741       else
3742          L1 := Type_Low_Bound  (T1);
3743          H1 := Type_High_Bound (T1);
3744
3745          L2 := Type_Low_Bound  (T2);
3746          H2 := Type_High_Bound (T2);
3747
3748          --  Check bounds to see if comparison possible at compile time
3749
3750          if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
3751               and then
3752             Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
3753          then
3754             return True;
3755          end if;
3756
3757          --  If bounds not comparable at compile time, then the bounds of T2
3758          --  must be compile time known or we cannot answer the query.
3759
3760          if not Compile_Time_Known_Value (L2)
3761            or else not Compile_Time_Known_Value (H2)
3762          then
3763             return False;
3764          end if;
3765
3766          --  If the bounds of T1 are know at compile time then use these
3767          --  ones, otherwise use the bounds of the base type (which are of
3768          --  course always static).
3769
3770          if not Compile_Time_Known_Value (L1) then
3771             L1 := Type_Low_Bound (Base_Type (T1));
3772          end if;
3773
3774          if not Compile_Time_Known_Value (H1) then
3775             H1 := Type_High_Bound (Base_Type (T1));
3776          end if;
3777
3778          --  Fixed point types should be considered as such only if
3779          --  flag Fixed_Int is set to False.
3780
3781          if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
3782            or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
3783            or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
3784          then
3785             return
3786               Expr_Value_R (L2) <= Expr_Value_R (L1)
3787                 and then
3788               Expr_Value_R (H2) >= Expr_Value_R (H1);
3789
3790          else
3791             return
3792               Expr_Value (L2) <= Expr_Value (L1)
3793                 and then
3794               Expr_Value (H2) >= Expr_Value (H1);
3795
3796          end if;
3797       end if;
3798
3799    --  If any exception occurs, it means that we have some bug in the compiler
3800    --  possibly triggered by a previous error, or by some unforeseen peculiar
3801    --  occurrence. However, this is only an optimization attempt, so there is
3802    --  really no point in crashing the compiler. Instead we just decide, too
3803    --  bad, we can't figure out the answer in this case after all.
3804
3805    exception
3806       when others =>
3807
3808          --  Debug flag K disables this behavior (useful for debugging)
3809
3810          if Debug_Flag_K then
3811             raise;
3812          else
3813             return False;
3814          end if;
3815    end In_Subrange_Of;
3816
3817    -----------------
3818    -- Is_In_Range --
3819    -----------------
3820
3821    function Is_In_Range
3822      (N            : Node_Id;
3823       Typ          : Entity_Id;
3824       Assume_Valid : Boolean := False;
3825       Fixed_Int    : Boolean := False;
3826       Int_Real     : Boolean := False) return Boolean
3827    is
3828       Val  : Uint;
3829       Valr : Ureal;
3830
3831       pragma Warnings (Off, Assume_Valid);
3832       --  For now Assume_Valid is unreferenced since the current implementation
3833       --  always returns False if N is not a compile time known value, but we
3834       --  keep the parameter to allow for future enhancements in which we try
3835       --  to get the information in the variable case as well.
3836
3837    begin
3838       --  Universal types have no range limits, so always in range
3839
3840       if Typ = Universal_Integer or else Typ = Universal_Real then
3841          return True;
3842
3843       --  Never in range if not scalar type. Don't know if this can
3844       --  actually happen, but our spec allows it, so we must check!
3845
3846       elsif not Is_Scalar_Type (Typ) then
3847          return False;
3848
3849       --  Never in range unless we have a compile time known value
3850
3851       elsif not Compile_Time_Known_Value (N) then
3852          return False;
3853
3854       --  General processing with a known compile time value
3855
3856       else
3857          declare
3858             Lo       : Node_Id;
3859             Hi       : Node_Id;
3860             LB_Known : Boolean;
3861             UB_Known : Boolean;
3862
3863          begin
3864             Lo := Type_Low_Bound  (Typ);
3865             Hi := Type_High_Bound (Typ);
3866
3867             LB_Known := Compile_Time_Known_Value (Lo);
3868             UB_Known := Compile_Time_Known_Value (Hi);
3869
3870             --  Fixed point types should be considered as such only in
3871             --  flag Fixed_Int is set to False.
3872
3873             if Is_Floating_Point_Type (Typ)
3874               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3875               or else Int_Real
3876             then
3877                Valr := Expr_Value_R (N);
3878
3879                if LB_Known and then Valr >= Expr_Value_R (Lo)
3880                  and then UB_Known and then Valr <= Expr_Value_R (Hi)
3881                then
3882                   return True;
3883                else
3884                   return False;
3885                end if;
3886
3887             else
3888                Val := Expr_Value (N);
3889
3890                if         LB_Known and then Val >= Expr_Value (Lo)
3891                  and then UB_Known and then Val <= Expr_Value (Hi)
3892                then
3893                   return True;
3894                else
3895                   return False;
3896                end if;
3897             end if;
3898          end;
3899       end if;
3900    end Is_In_Range;
3901
3902    -------------------
3903    -- Is_Null_Range --
3904    -------------------
3905
3906    function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3907       Typ : constant Entity_Id := Etype (Lo);
3908
3909    begin
3910       if not Compile_Time_Known_Value (Lo)
3911         or else not Compile_Time_Known_Value (Hi)
3912       then
3913          return False;
3914       end if;
3915
3916       if Is_Discrete_Type (Typ) then
3917          return Expr_Value (Lo) > Expr_Value (Hi);
3918
3919       else
3920          pragma Assert (Is_Real_Type (Typ));
3921          return Expr_Value_R (Lo) > Expr_Value_R (Hi);
3922       end if;
3923    end Is_Null_Range;
3924
3925    -----------------------------
3926    -- Is_OK_Static_Expression --
3927    -----------------------------
3928
3929    function Is_OK_Static_Expression (N : Node_Id) return Boolean is
3930    begin
3931       return Is_Static_Expression (N)
3932         and then not Raises_Constraint_Error (N);
3933    end Is_OK_Static_Expression;
3934
3935    ------------------------
3936    -- Is_OK_Static_Range --
3937    ------------------------
3938
3939    --  A static range is a range whose bounds are static expressions, or a
3940    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3941    --  We have already converted range attribute references, so we get the
3942    --  "or" part of this rule without needing a special test.
3943
3944    function Is_OK_Static_Range (N : Node_Id) return Boolean is
3945    begin
3946       return Is_OK_Static_Expression (Low_Bound (N))
3947         and then Is_OK_Static_Expression (High_Bound (N));
3948    end Is_OK_Static_Range;
3949
3950    --------------------------
3951    -- Is_OK_Static_Subtype --
3952    --------------------------
3953
3954    --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
3955    --  where neither bound raises constraint error when evaluated.
3956
3957    function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
3958       Base_T   : constant Entity_Id := Base_Type (Typ);
3959       Anc_Subt : Entity_Id;
3960
3961    begin
3962       --  First a quick check on the non static subtype flag. As described
3963       --  in further detail in Einfo, this flag is not decisive in all cases,
3964       --  but if it is set, then the subtype is definitely non-static.
3965
3966       if Is_Non_Static_Subtype (Typ) then
3967          return False;
3968       end if;
3969
3970       Anc_Subt := Ancestor_Subtype (Typ);
3971
3972       if Anc_Subt = Empty then
3973          Anc_Subt := Base_T;
3974       end if;
3975
3976       if Is_Generic_Type (Root_Type (Base_T))
3977         or else Is_Generic_Actual_Type (Base_T)
3978       then
3979          return False;
3980
3981       --  String types
3982
3983       elsif Is_String_Type (Typ) then
3984          return
3985            Ekind (Typ) = E_String_Literal_Subtype
3986              or else
3987            (Is_OK_Static_Subtype (Component_Type (Typ))
3988               and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
3989
3990       --  Scalar types
3991
3992       elsif Is_Scalar_Type (Typ) then
3993          if Base_T = Typ then
3994             return True;
3995
3996          else
3997             --  Scalar_Range (Typ) might be an N_Subtype_Indication, so
3998             --  use Get_Type_Low,High_Bound.
3999
4000             return     Is_OK_Static_Subtype (Anc_Subt)
4001               and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4002               and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4003          end if;
4004
4005       --  Types other than string and scalar types are never static
4006
4007       else
4008          return False;
4009       end if;
4010    end Is_OK_Static_Subtype;
4011
4012    ---------------------
4013    -- Is_Out_Of_Range --
4014    ---------------------
4015
4016    function Is_Out_Of_Range
4017      (N            : Node_Id;
4018       Typ          : Entity_Id;
4019       Assume_Valid : Boolean := False;
4020       Fixed_Int    : Boolean := False;
4021       Int_Real     : Boolean := False) return Boolean
4022    is
4023       Val  : Uint;
4024       Valr : Ureal;
4025
4026       pragma Warnings (Off, Assume_Valid);
4027       --  For now Assume_Valid is unreferenced since the current implementation
4028       --  always returns False if N is not a compile time known value, but we
4029       --  keep the parameter to allow for future enhancements in which we try
4030       --  to get the information in the variable case as well.
4031
4032    begin
4033       --  Universal types have no range limits, so always in range
4034
4035       if Typ = Universal_Integer or else Typ = Universal_Real then
4036          return False;
4037
4038       --  Never out of range if not scalar type. Don't know if this can
4039       --  actually happen, but our spec allows it, so we must check!
4040
4041       elsif not Is_Scalar_Type (Typ) then
4042          return False;
4043
4044       --  Never out of range if this is a generic type, since the bounds
4045       --  of generic types are junk. Note that if we only checked for
4046       --  static expressions (instead of compile time known values) below,
4047       --  we would not need this check, because values of a generic type
4048       --  can never be static, but they can be known at compile time.
4049
4050       elsif Is_Generic_Type (Typ) then
4051          return False;
4052
4053       --  Never out of range unless we have a compile time known value
4054
4055       elsif not Compile_Time_Known_Value (N) then
4056          return False;
4057
4058       else
4059          declare
4060             Lo       : Node_Id;
4061             Hi       : Node_Id;
4062             LB_Known : Boolean;
4063             UB_Known : Boolean;
4064
4065          begin
4066             Lo := Type_Low_Bound (Typ);
4067             Hi := Type_High_Bound (Typ);
4068
4069             LB_Known := Compile_Time_Known_Value (Lo);
4070             UB_Known := Compile_Time_Known_Value (Hi);
4071
4072             --  Real types (note that fixed-point types are not treated
4073             --  as being of a real type if the flag Fixed_Int is set,
4074             --  since in that case they are regarded as integer types).
4075
4076             if Is_Floating_Point_Type (Typ)
4077               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
4078               or else Int_Real
4079             then
4080                Valr := Expr_Value_R (N);
4081
4082                if LB_Known and then Valr < Expr_Value_R (Lo) then
4083                   return True;
4084
4085                elsif UB_Known and then Expr_Value_R (Hi) < Valr then
4086                   return True;
4087
4088                else
4089                   return False;
4090                end if;
4091
4092             else
4093                Val := Expr_Value (N);
4094
4095                if LB_Known and then Val < Expr_Value (Lo) then
4096                   return True;
4097
4098                elsif UB_Known and then Expr_Value (Hi) < Val then
4099                   return True;
4100
4101                else
4102                   return False;
4103                end if;
4104             end if;
4105          end;
4106       end if;
4107    end Is_Out_Of_Range;
4108
4109    ---------------------
4110    -- Is_Static_Range --
4111    ---------------------
4112
4113    --  A static range is a range whose bounds are static expressions, or a
4114    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4115    --  We have already converted range attribute references, so we get the
4116    --  "or" part of this rule without needing a special test.
4117
4118    function Is_Static_Range (N : Node_Id) return Boolean is
4119    begin
4120       return Is_Static_Expression (Low_Bound (N))
4121         and then Is_Static_Expression (High_Bound (N));
4122    end Is_Static_Range;
4123
4124    -----------------------
4125    -- Is_Static_Subtype --
4126    -----------------------
4127
4128    --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
4129
4130    function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4131       Base_T   : constant Entity_Id := Base_Type (Typ);
4132       Anc_Subt : Entity_Id;
4133
4134    begin
4135       --  First a quick check on the non static subtype flag. As described
4136       --  in further detail in Einfo, this flag is not decisive in all cases,
4137       --  but if it is set, then the subtype is definitely non-static.
4138
4139       if Is_Non_Static_Subtype (Typ) then
4140          return False;
4141       end if;
4142
4143       Anc_Subt := Ancestor_Subtype (Typ);
4144
4145       if Anc_Subt = Empty then
4146          Anc_Subt := Base_T;
4147       end if;
4148
4149       if Is_Generic_Type (Root_Type (Base_T))
4150         or else Is_Generic_Actual_Type (Base_T)
4151       then
4152          return False;
4153
4154       --  String types
4155
4156       elsif Is_String_Type (Typ) then
4157          return
4158            Ekind (Typ) = E_String_Literal_Subtype
4159              or else
4160            (Is_Static_Subtype (Component_Type (Typ))
4161               and then Is_Static_Subtype (Etype (First_Index (Typ))));
4162
4163       --  Scalar types
4164
4165       elsif Is_Scalar_Type (Typ) then
4166          if Base_T = Typ then
4167             return True;
4168
4169          else
4170             return     Is_Static_Subtype (Anc_Subt)
4171               and then Is_Static_Expression (Type_Low_Bound (Typ))
4172               and then Is_Static_Expression (Type_High_Bound (Typ));
4173          end if;
4174
4175       --  Types other than string and scalar types are never static
4176
4177       else
4178          return False;
4179       end if;
4180    end Is_Static_Subtype;
4181
4182    --------------------
4183    -- Not_Null_Range --
4184    --------------------
4185
4186    function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4187       Typ : constant Entity_Id := Etype (Lo);
4188
4189    begin
4190       if not Compile_Time_Known_Value (Lo)
4191         or else not Compile_Time_Known_Value (Hi)
4192       then
4193          return False;
4194       end if;
4195
4196       if Is_Discrete_Type (Typ) then
4197          return Expr_Value (Lo) <= Expr_Value (Hi);
4198
4199       else
4200          pragma Assert (Is_Real_Type (Typ));
4201
4202          return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
4203       end if;
4204    end Not_Null_Range;
4205
4206    -------------
4207    -- OK_Bits --
4208    -------------
4209
4210    function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
4211    begin
4212       --  We allow a maximum of 500,000 bits which seems a reasonable limit
4213
4214       if Bits < 500_000 then
4215          return True;
4216
4217       else
4218          Error_Msg_N ("static value too large, capacity exceeded", N);
4219          return False;
4220       end if;
4221    end OK_Bits;
4222
4223    ------------------
4224    -- Out_Of_Range --
4225    ------------------
4226
4227    procedure Out_Of_Range (N : Node_Id) is
4228    begin
4229       --  If we have the static expression case, then this is an illegality
4230       --  in Ada 95 mode, except that in an instance, we never generate an
4231       --  error (if the error is legitimate, it was already diagnosed in
4232       --  the template). The expression to compute the length of a packed
4233       --  array is attached to the array type itself, and deserves a separate
4234       --  message.
4235
4236       if Is_Static_Expression (N)
4237         and then not In_Instance
4238         and then not In_Inlined_Body
4239         and then Ada_Version >= Ada_95
4240       then
4241          if Nkind (Parent (N)) = N_Defining_Identifier
4242            and then Is_Array_Type (Parent (N))
4243            and then Present (Packed_Array_Type (Parent (N)))
4244            and then Present (First_Rep_Item (Parent (N)))
4245          then
4246             Error_Msg_N
4247              ("length of packed array must not exceed Integer''Last",
4248               First_Rep_Item (Parent (N)));
4249             Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
4250
4251          else
4252             Apply_Compile_Time_Constraint_Error
4253               (N, "value not in range of}", CE_Range_Check_Failed);
4254          end if;
4255
4256       --  Here we generate a warning for the Ada 83 case, or when we are
4257       --  in an instance, or when we have a non-static expression case.
4258
4259       else
4260          Apply_Compile_Time_Constraint_Error
4261            (N, "value not in range of}?", CE_Range_Check_Failed);
4262       end if;
4263    end Out_Of_Range;
4264
4265    -------------------------
4266    -- Rewrite_In_Raise_CE --
4267    -------------------------
4268
4269    procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
4270       Typ : constant Entity_Id := Etype (N);
4271
4272    begin
4273       --  If we want to raise CE in the condition of a raise_CE node
4274       --  we may as well get rid of the condition
4275
4276       if Present (Parent (N))
4277         and then Nkind (Parent (N)) = N_Raise_Constraint_Error
4278       then
4279          Set_Condition (Parent (N), Empty);
4280
4281       --  If the expression raising CE is a N_Raise_CE node, we can use
4282       --  that one. We just preserve the type of the context
4283
4284       elsif Nkind (Exp) = N_Raise_Constraint_Error then
4285          Rewrite (N, Exp);
4286          Set_Etype (N, Typ);
4287
4288       --  We have to build an explicit raise_ce node
4289
4290       else
4291          Rewrite (N,
4292            Make_Raise_Constraint_Error (Sloc (Exp),
4293              Reason => CE_Range_Check_Failed));
4294          Set_Raises_Constraint_Error (N);
4295          Set_Etype (N, Typ);
4296       end if;
4297    end Rewrite_In_Raise_CE;
4298
4299    ---------------------
4300    -- String_Type_Len --
4301    ---------------------
4302
4303    function String_Type_Len (Stype : Entity_Id) return Uint is
4304       NT : constant Entity_Id := Etype (First_Index (Stype));
4305       T  : Entity_Id;
4306
4307    begin
4308       if Is_OK_Static_Subtype (NT) then
4309          T := NT;
4310       else
4311          T := Base_Type (NT);
4312       end if;
4313
4314       return Expr_Value (Type_High_Bound (T)) -
4315              Expr_Value (Type_Low_Bound (T)) + 1;
4316    end String_Type_Len;
4317
4318    ------------------------------------
4319    -- Subtypes_Statically_Compatible --
4320    ------------------------------------
4321
4322    function Subtypes_Statically_Compatible
4323      (T1 : Entity_Id;
4324       T2 : Entity_Id) return Boolean
4325    is
4326    begin
4327       if Is_Scalar_Type (T1) then
4328
4329          --  Definitely compatible if we match
4330
4331          if Subtypes_Statically_Match (T1, T2) then
4332             return True;
4333
4334          --  If either subtype is nonstatic then they're not compatible
4335
4336          elsif not Is_Static_Subtype (T1)
4337            or else not Is_Static_Subtype (T2)
4338          then
4339             return False;
4340
4341          --  If either type has constraint error bounds, then consider that
4342          --  they match to avoid junk cascaded errors here.
4343
4344          elsif not Is_OK_Static_Subtype (T1)
4345            or else not Is_OK_Static_Subtype (T2)
4346          then
4347             return True;
4348
4349          --  Base types must match, but we don't check that (should
4350          --  we???) but we do at least check that both types are
4351          --  real, or both types are not real.
4352
4353          elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
4354             return False;
4355
4356          --  Here we check the bounds
4357
4358          else
4359             declare
4360                LB1 : constant Node_Id := Type_Low_Bound  (T1);
4361                HB1 : constant Node_Id := Type_High_Bound (T1);
4362                LB2 : constant Node_Id := Type_Low_Bound  (T2);
4363                HB2 : constant Node_Id := Type_High_Bound (T2);
4364
4365             begin
4366                if Is_Real_Type (T1) then
4367                   return
4368                     (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4369                       or else
4370                     (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4371                        and then
4372                      Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4373
4374                else
4375                   return
4376                     (Expr_Value (LB1) > Expr_Value (HB1))
4377                       or else
4378                     (Expr_Value (LB2) <= Expr_Value (LB1)
4379                        and then
4380                      Expr_Value (HB1) <= Expr_Value (HB2));
4381                end if;
4382             end;
4383          end if;
4384
4385       elsif Is_Access_Type (T1) then
4386          return not Is_Constrained (T2)
4387            or else Subtypes_Statically_Match
4388                      (Designated_Type (T1), Designated_Type (T2));
4389
4390       else
4391          return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4392            or else Subtypes_Statically_Match (T1, T2);
4393       end if;
4394    end Subtypes_Statically_Compatible;
4395
4396    -------------------------------
4397    -- Subtypes_Statically_Match --
4398    -------------------------------
4399
4400    --  Subtypes statically match if they have statically matching constraints
4401    --  (RM 4.9.1(2)). Constraints statically match if there are none, or if
4402    --  they are the same identical constraint, or if they are static and the
4403    --  values match (RM 4.9.1(1)).
4404
4405    function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
4406    begin
4407       --  A type always statically matches itself
4408
4409       if T1 = T2 then
4410          return True;
4411
4412       --  Scalar types
4413
4414       elsif Is_Scalar_Type (T1) then
4415
4416          --  Base types must be the same
4417
4418          if Base_Type (T1) /= Base_Type (T2) then
4419             return False;
4420          end if;
4421
4422          --  A constrained numeric subtype never matches an unconstrained
4423          --  subtype, i.e. both types must be constrained or unconstrained.
4424
4425          --  To understand the requirement for this test, see RM 4.9.1(1).
4426          --  As is made clear in RM 3.5.4(11), type Integer, for example
4427          --  is a constrained subtype with constraint bounds matching the
4428          --  bounds of its corresponding unconstrained base type. In this
4429          --  situation, Integer and Integer'Base do not statically match,
4430          --  even though they have the same bounds.
4431
4432          --  We only apply this test to types in Standard and types that
4433          --  appear in user programs. That way, we do not have to be
4434          --  too careful about setting Is_Constrained right for itypes.
4435
4436          if Is_Numeric_Type (T1)
4437            and then (Is_Constrained (T1) /= Is_Constrained (T2))
4438            and then (Scope (T1) = Standard_Standard
4439                       or else Comes_From_Source (T1))
4440            and then (Scope (T2) = Standard_Standard
4441                       or else Comes_From_Source (T2))
4442          then
4443             return False;
4444
4445          --  A generic scalar type does not statically match its base
4446          --  type (AI-311). In this case we make sure that the formals,
4447          --  which are first subtypes of their bases, are constrained.
4448
4449          elsif Is_Generic_Type (T1)
4450            and then Is_Generic_Type (T2)
4451            and then (Is_Constrained (T1) /= Is_Constrained (T2))
4452          then
4453             return False;
4454          end if;
4455
4456          --  If there was an error in either range, then just assume
4457          --  the types statically match to avoid further junk errors
4458
4459          if Error_Posted (Scalar_Range (T1))
4460               or else
4461             Error_Posted (Scalar_Range (T2))
4462          then
4463             return True;
4464          end if;
4465
4466          --  Otherwise both types have bound that can be compared
4467
4468          declare
4469             LB1 : constant Node_Id := Type_Low_Bound  (T1);
4470             HB1 : constant Node_Id := Type_High_Bound (T1);
4471             LB2 : constant Node_Id := Type_Low_Bound  (T2);
4472             HB2 : constant Node_Id := Type_High_Bound (T2);
4473
4474          begin
4475             --  If the bounds are the same tree node, then match
4476
4477             if LB1 = LB2 and then HB1 = HB2 then
4478                return True;
4479
4480             --  Otherwise bounds must be static and identical value
4481
4482             else
4483                if not Is_Static_Subtype (T1)
4484                  or else not Is_Static_Subtype (T2)
4485                then
4486                   return False;
4487
4488                --  If either type has constraint error bounds, then say
4489                --  that they match to avoid junk cascaded errors here.
4490
4491                elsif not Is_OK_Static_Subtype (T1)
4492                  or else not Is_OK_Static_Subtype (T2)
4493                then
4494                   return True;
4495
4496                elsif Is_Real_Type (T1) then
4497                   return
4498                     (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4499                       and then
4500                     (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4501
4502                else
4503                   return
4504                     Expr_Value (LB1) = Expr_Value (LB2)
4505                       and then
4506                     Expr_Value (HB1) = Expr_Value (HB2);
4507                end if;
4508             end if;
4509          end;
4510
4511       --  Type with discriminants
4512
4513       elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
4514
4515          --  Because of view exchanges in multiple instantiations, conformance
4516          --  checking might try to match a partial view of a type with no
4517          --  discriminants with a full view that has defaulted discriminants.
4518          --  In such a case, use the discriminant constraint of the full view,
4519          --  which must exist because we know that the two subtypes have the
4520          --  same base type.
4521
4522          if Has_Discriminants (T1) /= Has_Discriminants (T2) then
4523             if In_Instance then
4524                if Is_Private_Type (T2)
4525                  and then Present (Full_View (T2))
4526                  and then Has_Discriminants (Full_View (T2))
4527                then
4528                   return Subtypes_Statically_Match (T1, Full_View (T2));
4529
4530                elsif Is_Private_Type (T1)
4531                  and then Present (Full_View (T1))
4532                  and then Has_Discriminants (Full_View (T1))
4533                then
4534                   return Subtypes_Statically_Match (Full_View (T1), T2);
4535
4536                else
4537                   return False;
4538                end if;
4539             else
4540                return False;
4541             end if;
4542          end if;
4543
4544          declare
4545             DL1 : constant Elist_Id := Discriminant_Constraint (T1);
4546             DL2 : constant Elist_Id := Discriminant_Constraint (T2);
4547
4548             DA1 : Elmt_Id;
4549             DA2 : Elmt_Id;
4550
4551          begin
4552             if DL1 = DL2 then
4553                return True;
4554             elsif Is_Constrained (T1) /= Is_Constrained (T2) then
4555                return False;
4556             end if;
4557
4558             --  Now loop through the discriminant constraints
4559
4560             --  Note: the guard here seems necessary, since it is possible at
4561             --  least for DL1 to be No_Elist. Not clear this is reasonable ???
4562
4563             if Present (DL1) and then Present (DL2) then
4564                DA1 := First_Elmt (DL1);
4565                DA2 := First_Elmt (DL2);
4566                while Present (DA1) loop
4567                   declare
4568                      Expr1 : constant Node_Id := Node (DA1);
4569                      Expr2 : constant Node_Id := Node (DA2);
4570
4571                   begin
4572                      if not Is_Static_Expression (Expr1)
4573                        or else not Is_Static_Expression (Expr2)
4574                      then
4575                         return False;
4576
4577                         --  If either expression raised a constraint error,
4578                         --  consider the expressions as matching, since this
4579                         --  helps to prevent cascading errors.
4580
4581                      elsif Raises_Constraint_Error (Expr1)
4582                        or else Raises_Constraint_Error (Expr2)
4583                      then
4584                         null;
4585
4586                      elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
4587                         return False;
4588                      end if;
4589                   end;
4590
4591                   Next_Elmt (DA1);
4592                   Next_Elmt (DA2);
4593                end loop;
4594             end if;
4595          end;
4596
4597          return True;
4598
4599       --  A definite type does not match an indefinite or classwide type
4600       --  However, a generic type with unknown discriminants may be
4601       --  instantiated with a type with no discriminants, and conformance
4602       --  checking on an inherited operation may compare the actual with
4603       --  the subtype that renames it in the instance.
4604
4605       elsif
4606          Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
4607       then
4608          return
4609            Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
4610
4611       --  Array type
4612
4613       elsif Is_Array_Type (T1) then
4614
4615          --  If either subtype is unconstrained then both must be,
4616          --  and if both are unconstrained then no further checking
4617          --  is needed.
4618
4619          if not Is_Constrained (T1) or else not Is_Constrained (T2) then
4620             return not (Is_Constrained (T1) or else Is_Constrained (T2));
4621          end if;
4622
4623          --  Both subtypes are constrained, so check that the index
4624          --  subtypes statically match.
4625
4626          declare
4627             Index1 : Node_Id := First_Index (T1);
4628             Index2 : Node_Id := First_Index (T2);
4629
4630          begin
4631             while Present (Index1) loop
4632                if not
4633                  Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
4634                then
4635                   return False;
4636                end if;
4637
4638                Next_Index (Index1);
4639                Next_Index (Index2);
4640             end loop;
4641
4642             return True;
4643          end;
4644
4645       elsif Is_Access_Type (T1) then
4646          if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
4647             return False;
4648
4649          elsif Ekind (T1) = E_Access_Subprogram_Type
4650            or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type
4651          then
4652             return
4653               Subtype_Conformant
4654                 (Designated_Type (T1),
4655                  Designated_Type (T2));
4656          else
4657             return
4658               Subtypes_Statically_Match
4659                 (Designated_Type (T1),
4660                  Designated_Type (T2))
4661               and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
4662          end if;
4663
4664       --  All other types definitely match
4665
4666       else
4667          return True;
4668       end if;
4669    end Subtypes_Statically_Match;
4670
4671    ----------
4672    -- Test --
4673    ----------
4674
4675    function Test (Cond : Boolean) return Uint is
4676    begin
4677       if Cond then
4678          return Uint_1;
4679       else
4680          return Uint_0;
4681       end if;
4682    end Test;
4683
4684    ---------------------------------
4685    -- Test_Expression_Is_Foldable --
4686    ---------------------------------
4687
4688    --  One operand case
4689
4690    procedure Test_Expression_Is_Foldable
4691      (N    : Node_Id;
4692       Op1  : Node_Id;
4693       Stat : out Boolean;
4694       Fold : out Boolean)
4695    is
4696    begin
4697       Stat := False;
4698       Fold := False;
4699
4700       if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4701          return;
4702       end if;
4703
4704       --  If operand is Any_Type, just propagate to result and do not
4705       --  try to fold, this prevents cascaded errors.
4706
4707       if Etype (Op1) = Any_Type then
4708          Set_Etype (N, Any_Type);
4709          return;
4710
4711       --  If operand raises constraint error, then replace node N with the
4712       --  raise constraint error node, and we are obviously not foldable.
4713       --  Note that this replacement inherits the Is_Static_Expression flag
4714       --  from the operand.
4715
4716       elsif Raises_Constraint_Error (Op1) then
4717          Rewrite_In_Raise_CE (N, Op1);
4718          return;
4719
4720       --  If the operand is not static, then the result is not static, and
4721       --  all we have to do is to check the operand since it is now known
4722       --  to appear in a non-static context.
4723
4724       elsif not Is_Static_Expression (Op1) then
4725          Check_Non_Static_Context (Op1);
4726          Fold := Compile_Time_Known_Value (Op1);
4727          return;
4728
4729       --   An expression of a formal modular type is not foldable because
4730       --   the modulus is unknown.
4731
4732       elsif Is_Modular_Integer_Type (Etype (Op1))
4733         and then Is_Generic_Type (Etype (Op1))
4734       then
4735          Check_Non_Static_Context (Op1);
4736          return;
4737
4738       --  Here we have the case of an operand whose type is OK, which is
4739       --  static, and which does not raise constraint error, we can fold.
4740
4741       else
4742          Set_Is_Static_Expression (N);
4743          Fold := True;
4744          Stat := True;
4745       end if;
4746    end Test_Expression_Is_Foldable;
4747
4748    --  Two operand case
4749
4750    procedure Test_Expression_Is_Foldable
4751      (N    : Node_Id;
4752       Op1  : Node_Id;
4753       Op2  : Node_Id;
4754       Stat : out Boolean;
4755       Fold : out Boolean)
4756    is
4757       Rstat : constant Boolean := Is_Static_Expression (Op1)
4758                                     and then Is_Static_Expression (Op2);
4759
4760    begin
4761       Stat := False;
4762       Fold := False;
4763
4764       if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4765          return;
4766       end if;
4767
4768       --  If either operand is Any_Type, just propagate to result and
4769       --  do not try to fold, this prevents cascaded errors.
4770
4771       if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
4772          Set_Etype (N, Any_Type);
4773          return;
4774
4775       --  If left operand raises constraint error, then replace node N with
4776       --  the raise constraint error node, and we are obviously not foldable.
4777       --  Is_Static_Expression is set from the two operands in the normal way,
4778       --  and we check the right operand if it is in a non-static context.
4779
4780       elsif Raises_Constraint_Error (Op1) then
4781          if not Rstat then
4782             Check_Non_Static_Context (Op2);
4783          end if;
4784
4785          Rewrite_In_Raise_CE (N, Op1);
4786          Set_Is_Static_Expression (N, Rstat);
4787          return;
4788
4789       --  Similar processing for the case of the right operand. Note that
4790       --  we don't use this routine for the short-circuit case, so we do
4791       --  not have to worry about that special case here.
4792
4793       elsif Raises_Constraint_Error (Op2) then
4794          if not Rstat then
4795             Check_Non_Static_Context (Op1);
4796          end if;
4797
4798          Rewrite_In_Raise_CE (N, Op2);
4799          Set_Is_Static_Expression (N, Rstat);
4800          return;
4801
4802       --  Exclude expressions of a generic modular type, as above
4803
4804       elsif Is_Modular_Integer_Type (Etype (Op1))
4805         and then Is_Generic_Type (Etype (Op1))
4806       then
4807          Check_Non_Static_Context (Op1);
4808          return;
4809
4810       --  If result is not static, then check non-static contexts on operands
4811       --  since one of them may be static and the other one may not be static
4812
4813       elsif not Rstat then
4814          Check_Non_Static_Context (Op1);
4815          Check_Non_Static_Context (Op2);
4816          Fold := Compile_Time_Known_Value (Op1)
4817                    and then Compile_Time_Known_Value (Op2);
4818          return;
4819
4820       --  Else result is static and foldable. Both operands are static,
4821       --  and neither raises constraint error, so we can definitely fold.
4822
4823       else
4824          Set_Is_Static_Expression (N);
4825          Fold := True;
4826          Stat := True;
4827          return;
4828       end if;
4829    end Test_Expression_Is_Foldable;
4830
4831    --------------
4832    -- To_Bits --
4833    --------------
4834
4835    procedure To_Bits (U : Uint; B : out Bits) is
4836    begin
4837       for J in 0 .. B'Last loop
4838          B (J) := (U / (2 ** J)) mod 2 /= 0;
4839       end loop;
4840    end To_Bits;
4841
4842    --------------------
4843    -- Why_Not_Static --
4844    --------------------
4845
4846    procedure Why_Not_Static (Expr : Node_Id) is
4847       N   : constant Node_Id   := Original_Node (Expr);
4848       Typ : Entity_Id;
4849       E   : Entity_Id;
4850
4851       procedure Why_Not_Static_List (L : List_Id);
4852       --  A version that can be called on a list of expressions. Finds
4853       --  all non-static violations in any element of the list.
4854
4855       -------------------------
4856       -- Why_Not_Static_List --
4857       -------------------------
4858
4859       procedure Why_Not_Static_List (L : List_Id) is
4860          N : Node_Id;
4861
4862       begin
4863          if Is_Non_Empty_List (L) then
4864             N := First (L);
4865             while Present (N) loop
4866                Why_Not_Static (N);
4867                Next (N);
4868             end loop;
4869          end if;
4870       end Why_Not_Static_List;
4871
4872    --  Start of processing for Why_Not_Static
4873
4874    begin
4875       --  If in ACATS mode (debug flag 2), then suppress all these
4876       --  messages, this avoids massive updates to the ACATS base line.
4877
4878       if Debug_Flag_2 then
4879          return;
4880       end if;
4881
4882       --  Ignore call on error or empty node
4883
4884       if No (Expr) or else Nkind (Expr) = N_Error then
4885          return;
4886       end if;
4887
4888       --  Preprocessing for sub expressions
4889
4890       if Nkind (Expr) in N_Subexpr then
4891
4892          --  Nothing to do if expression is static
4893
4894          if Is_OK_Static_Expression (Expr) then
4895             return;
4896          end if;
4897
4898          --  Test for constraint error raised
4899
4900          if Raises_Constraint_Error (Expr) then
4901             Error_Msg_N
4902               ("expression raises exception, cannot be static " &
4903                "(RM 4.9(34))!", N);
4904             return;
4905          end if;
4906
4907          --  If no type, then something is pretty wrong, so ignore
4908
4909          Typ := Etype (Expr);
4910
4911          if No (Typ) then
4912             return;
4913          end if;
4914
4915          --  Type must be scalar or string type
4916
4917          if not Is_Scalar_Type (Typ)
4918            and then not Is_String_Type (Typ)
4919          then
4920             Error_Msg_N
4921               ("static expression must have scalar or string type " &
4922                "(RM 4.9(2))!", N);
4923             return;
4924          end if;
4925       end if;
4926
4927       --  If we got through those checks, test particular node kind
4928
4929       case Nkind (N) is
4930          when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
4931             E := Entity (N);
4932
4933             if Is_Named_Number (E) then
4934                null;
4935
4936             elsif Ekind (E) = E_Constant then
4937                if not Is_Static_Expression (Constant_Value (E)) then
4938                   Error_Msg_NE
4939                     ("& is not a static constant (RM 4.9(5))!", N, E);
4940                end if;
4941
4942             else
4943                Error_Msg_NE
4944                  ("& is not static constant or named number " &
4945                   "(RM 4.9(5))!", N, E);
4946             end if;
4947
4948          when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
4949             if Nkind (N) in N_Op_Shift then
4950                Error_Msg_N
4951                 ("shift functions are never static (RM 4.9(6,18))!", N);
4952
4953             else
4954                Why_Not_Static (Left_Opnd (N));
4955                Why_Not_Static (Right_Opnd (N));
4956             end if;
4957
4958          when N_Unary_Op =>
4959             Why_Not_Static (Right_Opnd (N));
4960
4961          when N_Attribute_Reference =>
4962             Why_Not_Static_List (Expressions (N));
4963
4964             E := Etype (Prefix (N));
4965
4966             if E = Standard_Void_Type then
4967                return;
4968             end if;
4969
4970             --  Special case non-scalar'Size since this is a common error
4971
4972             if Attribute_Name (N) = Name_Size then
4973                Error_Msg_N
4974                  ("size attribute is only static for scalar type " &
4975                   "(RM 4.9(7,8))", N);
4976
4977             --  Flag array cases
4978
4979             elsif Is_Array_Type (E) then
4980                if Attribute_Name (N) /= Name_First
4981                     and then
4982                   Attribute_Name (N) /= Name_Last
4983                     and then
4984                   Attribute_Name (N) /= Name_Length
4985                then
4986                   Error_Msg_N
4987                     ("static array attribute must be Length, First, or Last " &
4988                      "(RM 4.9(8))!", N);
4989
4990                --  Since we know the expression is not-static (we already
4991                --  tested for this, must mean array is not static).
4992
4993                else
4994                   Error_Msg_N
4995                     ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
4996                end if;
4997
4998                return;
4999
5000             --  Special case generic types, since again this is a common
5001             --  source of confusion.
5002
5003             elsif Is_Generic_Actual_Type (E)
5004                     or else
5005                   Is_Generic_Type (E)
5006             then
5007                Error_Msg_N
5008                  ("attribute of generic type is never static " &
5009                   "(RM 4.9(7,8))!", N);
5010
5011             elsif Is_Static_Subtype (E) then
5012                null;
5013
5014             elsif Is_Scalar_Type (E) then
5015                Error_Msg_N
5016                  ("prefix type for attribute is not static scalar subtype " &
5017                   "(RM 4.9(7))!", N);
5018
5019             else
5020                Error_Msg_N
5021                  ("static attribute must apply to array/scalar type " &
5022                   "(RM 4.9(7,8))!", N);
5023             end if;
5024
5025          when N_String_Literal =>
5026             Error_Msg_N
5027               ("subtype of string literal is non-static (RM 4.9(4))!", N);
5028
5029          when N_Explicit_Dereference =>
5030             Error_Msg_N
5031               ("explicit dereference is never static (RM 4.9)!", N);
5032
5033          when N_Function_Call =>
5034             Why_Not_Static_List (Parameter_Associations (N));
5035             Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
5036
5037          when N_Parameter_Association =>
5038             Why_Not_Static (Explicit_Actual_Parameter (N));
5039
5040          when N_Indexed_Component =>
5041             Error_Msg_N
5042               ("indexed component is never static (RM 4.9)!", N);
5043
5044          when N_Procedure_Call_Statement =>
5045             Error_Msg_N
5046               ("procedure call is never static (RM 4.9)!", N);
5047
5048          when N_Qualified_Expression =>
5049             Why_Not_Static (Expression (N));
5050
5051          when N_Aggregate | N_Extension_Aggregate =>
5052             Error_Msg_N
5053               ("an aggregate is never static (RM 4.9)!", N);
5054
5055          when N_Range =>
5056             Why_Not_Static (Low_Bound (N));
5057             Why_Not_Static (High_Bound (N));
5058
5059          when N_Range_Constraint =>
5060             Why_Not_Static (Range_Expression (N));
5061
5062          when N_Subtype_Indication =>
5063             Why_Not_Static (Constraint (N));
5064
5065          when N_Selected_Component =>
5066             Error_Msg_N
5067               ("selected component is never static (RM 4.9)!", N);
5068
5069          when N_Slice =>
5070             Error_Msg_N
5071               ("slice is never static (RM 4.9)!", N);
5072
5073          when N_Type_Conversion =>
5074             Why_Not_Static (Expression (N));
5075
5076             if not Is_Scalar_Type (Etype (Prefix (N)))
5077               or else not Is_Static_Subtype (Etype (Prefix (N)))
5078             then
5079                Error_Msg_N
5080                  ("static conversion requires static scalar subtype result " &
5081                   "(RM 4.9(9))!", N);
5082             end if;
5083
5084          when N_Unchecked_Type_Conversion =>
5085             Error_Msg_N
5086               ("unchecked type conversion is never static (RM 4.9)!", N);
5087
5088          when others =>
5089             null;
5090
5091       end case;
5092    end Why_Not_Static;
5093
5094 end Sem_Eval;