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