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