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