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-2003 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Elists;   use Elists;
  32 with Errout;   use Errout;
  33 with Eval_Fat; use Eval_Fat;
  34 with Exp_Util; use Exp_Util;
  35 with Nmake;    use Nmake;
  36 with Nlists;   use Nlists;
  37 with Opt;      use Opt;
  38 with Sem;      use Sem;
  39 with Sem_Cat;  use Sem_Cat;
  40 with Sem_Ch8;  use Sem_Ch8;
  41 with Sem_Res;  use Sem_Res;
  42 with Sem_Util; use Sem_Util;
  43 with Sem_Type; use Sem_Type;
  44 with Sem_Warn; use Sem_Warn;
  45 with Sinfo;    use Sinfo;
  46 with Snames;   use Snames;
  47 with Stand;    use Stand;
  48 with Stringt;  use Stringt;
  49 with Tbuild;   use Tbuild;
  50
  51 package body Sem_Eval is
  52
  53    -----------------------------------------
  54    -- Handling of Compile Time Evaluation --
  55    -----------------------------------------
  56
  57    --  The compile time evaluation of expressions is distributed over several
  58    --  Eval_xxx procedures. These procedures are called immediatedly after
  59    --  a subexpression is resolved and is therefore accomplished in a bottom
  60    --  up fashion. The flags are synthesized using the following approach.
  61
  62    --    Is_Static_Expression is determined by following the detailed rules
  63    --    in RM 4.9(4-14). This involves testing the Is_Static_Expression
  64    --    flag of the operands in many cases.
  65
  66    --    Raises_Constraint_Error is set if any of the operands have the flag
  67    --    set or if an attempt to compute the value of the current expression
  68    --    results in detection of a runtime constraint error.
  69
  70    --  As described in the spec, the requirement is that Is_Static_Expression
  71    --  be accurately set, and in addition for nodes for which this flag is set,
  72    --  Raises_Constraint_Error must also be set. Furthermore a node which has
  73    --  Is_Static_Expression set, and Raises_Constraint_Error clear, then the
  74    --  requirement is that the expression value must be precomputed, and the
  75    --  node is either a literal, or the name of a constant entity whose value
  76    --  is a static expression.
  77
  78    --  The general approach is as follows. First compute Is_Static_Expression.
  79    --  If the node is not static, then the flag is left off in the node and
  80    --  we are all done. Otherwise for a static node, we test if any of the
  81    --  operands will raise constraint error, and if so, propagate the flag
  82    --  Raises_Constraint_Error to the result node and we are done (since the
  83    --  error was already posted at a lower level).
  84
  85    --  For the case of a static node whose operands do not raise constraint
  86    --  error, we attempt to evaluate the node. If this evaluation succeeds,
  87    --  then the node is replaced by the result of this computation. If the
  88    --  evaluation raises constraint error, then we rewrite the node with
  89    --  Apply_Compile_Time_Constraint_Error to raise the exception and also
  90    --  to post appropriate error messages.
  91
  92    ----------------
  93    -- Local Data --
  94    ----------------
  95
  96    type Bits is array (Nat range <>) of Boolean;
  97    --  Used to convert unsigned (modular) values for folding logical ops
  98
  99    --  The following definitions are used to maintain a cache of nodes that
 100    --  have compile time known values. The cache is maintained only for
 101    --  discrete types (the most common case), and is populated by calls to
 102    --  Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
 103    --  since it is possible for the status to change (in particular it is
 104    --  possible for a node to get replaced by a constraint error node).
 105
 106    CV_Bits : constant := 5;
 107    --  Number of low order bits of Node_Id value used to reference entries
 108    --  in the cache table.
 109
 110    CV_Cache_Size : constant Nat := 2 ** CV_Bits;
 111    --  Size of cache for compile time values
 112
 113    subtype CV_Range is Nat range 0 .. CV_Cache_Size;
 114
 115    type CV_Entry is record
 116       N : Node_Id;
 117       V : Uint;
 118    end record;
 119
 120    type CV_Cache_Array is array (CV_Range) of CV_Entry;
 121
 122    CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
 123    --  This is the actual cache, with entries consisting of node/value pairs,
 124    --  and the impossible value Node_High_Bound used for unset entries.
 125
 126    -----------------------
 127    -- Local Subprograms --
 128    -----------------------
 129
 130    function From_Bits (B : Bits; T : Entity_Id) return Uint;
 131    --  Converts a bit string of length B'Length to a Uint value to be used
 132    --  for a target of type T, which is a modular type. This procedure
 133    --  includes the necessary reduction by the modulus in the case of a
 134    --  non-binary modulus (for a binary modulus, the bit string is the
 135    --  right length any way so all is well).
 136
 137    function Get_String_Val (N : Node_Id) return Node_Id;
 138    --  Given a tree node for a folded string or character value, returns
 139    --  the corresponding string literal or character literal (one of the
 140    --  two must be available, or the operand would not have been marked
 141    --  as foldable in the earlier analysis of the operation).
 142
 143    function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
 144    --  Bits represents the number of bits in an integer value to be computed
 145    --  (but the value has not been computed yet). If this value in Bits is
 146    --  reasonable, a result of True is returned, with the implication that
 147    --  the caller should go ahead and complete the calculation. If the value
 148    --  in Bits is unreasonably large, then an error is posted on node N, and
 149    --  False is returned (and the caller skips the proposed calculation).
 150
 151    procedure Out_Of_Range (N : Node_Id);
 152    --  This procedure is called if it is determined that node N, which
 153    --  appears in a non-static context, is a compile time known value
 154    --  which is outside its range, i.e. the range of Etype. This is used
 155    --  in contexts where this is an illegality if N is static, and should
 156    --  generate a warning otherwise.
 157
 158    procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
 159    --  N and Exp are nodes representing an expression, Exp is known
 160    --  to raise CE. N is rewritten in term of Exp in the optimal way.
 161
 162    function String_Type_Len (Stype : Entity_Id) return Uint;
 163    --  Given a string type, determines the length of the index type, or,
 164    --  if this index type is non-static, the length of the base type of
 165    --  this index type. Note that if the string type is itself static,
 166    --  then the index type is static, so the second case applies only
 167    --  if the string type passed is non-static.
 168
 169    function Test (Cond : Boolean) return Uint;
 170    pragma Inline (Test);
 171    --  This function simply returns the appropriate Boolean'Pos value
 172    --  corresponding to the value of Cond as a universal integer. It is
 173    --  used for producing the result of the static evaluation of the
 174    --  logical operators
 175
 176    procedure Test_Expression_Is_Foldable
 177      (N    : Node_Id;
 178       Op1  : Node_Id;
 179       Stat : out Boolean;
 180       Fold : out Boolean);
 181    --  Tests to see if expression N whose single operand is Op1 is foldable,
 182    --  i.e. the operand value is known at compile time. If the operation is
 183    --  foldable, then Fold is True on return, and Stat indicates whether
 184    --  the result is static (i.e. both operands were static). Note that it
 185    --  is quite possible for Fold to be True, and Stat to be False, since
 186    --  there are cases in which we know the value of an operand even though
 187    --  it is not technically static (e.g. the static lower bound of a range
 188    --  whose upper bound is non-static).
 189    --
 190    --  If Stat is set False on return, then Expression_Is_Foldable makes a
 191    --  call to Check_Non_Static_Context on the operand. If Fold is False on
 192    --  return, then all processing is complete, and the caller should
 193    --  return, since there is nothing else to do.
 194
 195    procedure Test_Expression_Is_Foldable
 196      (N    : Node_Id;
 197       Op1  : Node_Id;
 198       Op2  : Node_Id;
 199       Stat : out Boolean;
 200       Fold : out Boolean);
 201    --  Same processing, except applies to an expression N with two operands
 202    --  Op1 and Op2.
 203
 204    procedure To_Bits (U : Uint; B : out Bits);
 205    --  Converts a Uint value to a bit string of length B'Length
 206
 207    ------------------------------
 208    -- Check_Non_Static_Context --
 209    ------------------------------
 210
 211    procedure Check_Non_Static_Context (N : Node_Id) is
 212       T         : constant Entity_Id := Etype (N);
 213       Checks_On : constant Boolean   :=
 214                     not Index_Checks_Suppressed (T)
 215                       and not Range_Checks_Suppressed (T);
 216
 217    begin
 218       --  Ignore cases of non-scalar types or error types
 219
 220       if T = Any_Type or else not Is_Scalar_Type (T) then
 221          return;
 222       end if;
 223
 224       --  At this stage we have a scalar type. If we have an expression
 225       --  that raises CE, then we already issued a warning or error msg
 226       --  so there is nothing more to be done in this routine.
 227
 228       if Raises_Constraint_Error (N) then
 229          return;
 230       end if;
 231
 232       --  Now we have a scalar type which is not marked as raising a
 233       --  constraint error exception. The main purpose of this routine
 234       --  is to deal with static expressions appearing in a non-static
 235       --  context. That means that if we do not have a static expression
 236       --  then there is not much to do. The one case that we deal with
 237       --  here is that if we have a floating-point value that is out of
 238       --  range, then we post a warning that an infinity will result.
 239
 240       if not Is_Static_Expression (N) then
 241          if Is_Floating_Point_Type (T)
 242            and then Is_Out_Of_Range (N, Base_Type (T))
 243          then
 244             Error_Msg_N
 245               ("?float value out of range, infinity will be generated", N);
 246          end if;
 247
 248          return;
 249       end if;
 250
 251       --  Here we have the case of outer level static expression of
 252       --  scalar type, where the processing of this procedure is needed.
 253
 254       --  For real types, this is where we convert the value to a machine
 255       --  number (see RM 4.9(38)). Also see ACVC test C490001. We should
 256       --  only need to do this if the parent is a constant declaration,
 257       --  since in other cases, gigi should do the necessary conversion
 258       --  correctly, but experimentation shows that this is not the case
 259       --  on all machines, in particular if we do not convert all literals
 260       --  to machine values in non-static contexts, then ACVC test C490001
 261       --  fails on Sparc/Solaris and SGI/Irix.
 262
 263       if Nkind (N) = N_Real_Literal
 264         and then not Is_Machine_Number (N)
 265         and then not Is_Generic_Type (Etype (N))
 266         and then Etype (N) /= Universal_Real
 267       then
 268          --  Check that value is in bounds before converting to machine
 269          --  number, so as not to lose case where value overflows in the
 270          --  least significant bit or less. See B490001.
 271
 272          if Is_Out_Of_Range (N, Base_Type (T)) then
 273             Out_Of_Range (N);
 274             return;
 275          end if;
 276
 277          --  Note: we have to copy the node, to avoid problems with conformance
 278          --  of very similar numbers (see ACVC tests B4A010C and B63103A).
 279
 280          Rewrite (N, New_Copy (N));
 281
 282          if not Is_Floating_Point_Type (T) then
 283             Set_Realval
 284               (N, Corresponding_Integer_Value (N) * Small_Value (T));
 285
 286          elsif not UR_Is_Zero (Realval (N)) then
 287
 288             --  Note: even though RM 4.9(38) specifies biased rounding,
 289             --  this has been modified by AI-100 in order to prevent
 290             --  confusing differences in rounding between static and
 291             --  non-static expressions. AI-100 specifies that the effect
 292             --  of such rounding is implementation dependent, and in GNAT
 293             --  we round to nearest even to match the run-time behavior.
 294
 295             Set_Realval
 296               (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
 297          end if;
 298
 299          Set_Is_Machine_Number (N);
 300       end if;
 301
 302       --  Check for out of range universal integer. This is a non-static
 303       --  context, so the integer value must be in range of the runtime
 304       --  representation of universal integers.
 305
 306       --  We do this only within an expression, because that is the only
 307       --  case in which non-static universal integer values can occur, and
 308       --  furthermore, Check_Non_Static_Context is currently (incorrectly???)
 309       --  called in contexts like the expression of a number declaration where
 310       --  we certainly want to allow out of range values.
 311
 312       if Etype (N) = Universal_Integer
 313         and then Nkind (N) = N_Integer_Literal
 314         and then Nkind (Parent (N)) in N_Subexpr
 315         and then
 316           (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
 317             or else
 318            Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
 319       then
 320          Apply_Compile_Time_Constraint_Error
 321            (N, "non-static universal integer value out of range?",
 322             CE_Range_Check_Failed);
 323
 324       --  Check out of range of base type
 325
 326       elsif Is_Out_Of_Range (N, Base_Type (T)) then
 327          Out_Of_Range (N);
 328
 329       --  Give warning if outside subtype (where one or both of the
 330       --  bounds of the subtype is static). This warning is omitted
 331       --  if the expression appears in a range that could be null
 332       --  (warnings are handled elsewhere for this case).
 333
 334       elsif T /= Base_Type (T)
 335         and then Nkind (Parent (N)) /= N_Range
 336       then
 337          if Is_In_Range (N, T) then
 338             null;
 339
 340          elsif Is_Out_Of_Range (N, T) then
 341             Apply_Compile_Time_Constraint_Error
 342               (N, "value not in range of}?", CE_Range_Check_Failed);
 343
 344          elsif Checks_On then
 345             Enable_Range_Check (N);
 346
 347          else
 348             Set_Do_Range_Check (N, False);
 349          end if;
 350       end if;
 351    end Check_Non_Static_Context;
 352
 353    ---------------------------------
 354    -- Check_String_Literal_Length --
 355    ---------------------------------
 356
 357    procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
 358    begin
 359       if not Raises_Constraint_Error (N)
 360         and then Is_Constrained (Ttype)
 361       then
 362          if
 363            UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
 364          then
 365             Apply_Compile_Time_Constraint_Error
 366               (N, "string length wrong for}?",
 367                CE_Length_Check_Failed,
 368                Ent => Ttype,
 369                Typ => Ttype);
 370          end if;
 371       end if;
 372    end Check_String_Literal_Length;
 373
 374    --------------------------
 375    -- Compile_Time_Compare --
 376    --------------------------
 377
 378    function Compile_Time_Compare
 379      (L, R : Node_Id;
 380       Rec  : Boolean := False)
 381       return Compare_Result
 382    is
 383       Ltyp : constant Entity_Id := Etype (L);
 384       Rtyp : constant Entity_Id := Etype (R);
 385
 386       procedure Compare_Decompose
 387         (N : Node_Id;
 388          R : out Node_Id;
 389          V : out Uint);
 390       --  This procedure decomposes the node N into an expression node
 391       --  and a signed offset, so that the value of N is equal to the
 392       --  value of R plus the value V (which may be negative). If no
 393       --  such decomposition is possible, then on return R is a copy
 394       --  of N, and V is set to zero.
 395
 396       function Compare_Fixup (N : Node_Id) return Node_Id;
 397       --  This function deals with replacing 'Last and 'First references
 398       --  with their corresponding type bounds, which we then can compare.
 399       --  The argument is the original node, the result is the identity,
 400       --  unless we have a 'Last/'First reference in which case the value
 401       --  returned is the appropriate type bound.
 402
 403       function Is_Same_Value (L, R : Node_Id) return Boolean;
 404       --  Returns True iff L and R represent expressions that definitely
 405       --  have identical (but not necessarily compile time known) values
 406       --  Indeed the caller is expected to have already dealt with the
 407       --  cases of compile time known values, so these are not tested here.
 408
 409       -----------------------
 410       -- Compare_Decompose --
 411       -----------------------
 412
 413       procedure Compare_Decompose
 414         (N : Node_Id;
 415          R : out Node_Id;
 416          V : out Uint)
 417       is
 418       begin
 419          if Nkind (N) = N_Op_Add
 420            and then Nkind (Right_Opnd (N)) = N_Integer_Literal
 421          then
 422             R := Left_Opnd (N);
 423             V := Intval (Right_Opnd (N));
 424             return;
 425
 426          elsif Nkind (N) = N_Op_Subtract
 427            and then Nkind (Right_Opnd (N)) = N_Integer_Literal
 428          then
 429             R := Left_Opnd (N);
 430             V := UI_Negate (Intval (Right_Opnd (N)));
 431             return;
 432
 433          elsif Nkind (N) = N_Attribute_Reference  then
 434
 435             if Attribute_Name (N) = Name_Succ then
 436                R := First (Expressions (N));
 437                V := Uint_1;
 438                return;
 439
 440             elsif Attribute_Name (N) = Name_Pred then
 441                R := First (Expressions (N));
 442                V := Uint_Minus_1;
 443                return;
 444             end if;
 445          end if;
 446
 447          R := N;
 448          V := Uint_0;
 449       end Compare_Decompose;
 450
 451       -------------------
 452       -- Compare_Fixup --
 453       -------------------
 454
 455       function Compare_Fixup (N : Node_Id) return Node_Id is
 456          Indx : Node_Id;
 457          Xtyp : Entity_Id;
 458          Subs : Nat;
 459
 460       begin
 461          if Nkind (N) = N_Attribute_Reference
 462            and then (Attribute_Name (N) = Name_First
 463                        or else
 464                      Attribute_Name (N) = Name_Last)
 465          then
 466             Xtyp := Etype (Prefix (N));
 467
 468             --  If we have no type, then just abandon the attempt to do
 469             --  a fixup, this is probably the result of some other error.
 470
 471             if No (Xtyp) then
 472                return N;
 473             end if;
 474
 475             --  Dereference an access type
 476
 477             if Is_Access_Type (Xtyp) then
 478                Xtyp := Designated_Type (Xtyp);
 479             end if;
 480
 481             --  If we don't have an array type at this stage, something
 482             --  is peculiar, e.g. another error, and we abandon the attempt
 483             --  at a fixup.
 484
 485             if not Is_Array_Type (Xtyp) then
 486                return N;
 487             end if;
 488
 489             --  Ignore unconstrained array, since bounds are not meaningful
 490
 491             if not Is_Constrained (Xtyp) then
 492                return N;
 493             end if;
 494
 495             if Ekind (Xtyp) = E_String_Literal_Subtype then
 496                if Attribute_Name (N) = Name_First then
 497                   return String_Literal_Low_Bound (Xtyp);
 498
 499                else         -- Attribute_Name (N) = Name_Last
 500                   return Make_Integer_Literal (Sloc (N),
 501                     Intval => Intval (String_Literal_Low_Bound (Xtyp))
 502                        + String_Literal_Length (Xtyp));
 503                end if;
 504             end if;
 505
 506             --  Find correct index type
 507
 508             Indx := First_Index (Xtyp);
 509
 510             if Present (Expressions (N)) then
 511                Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
 512
 513                for J in 2 .. Subs loop
 514                   Indx := Next_Index (Indx);
 515                end loop;
 516             end if;
 517
 518             Xtyp := Etype (Indx);
 519
 520             if Attribute_Name (N) = Name_First then
 521                return Type_Low_Bound (Xtyp);
 522
 523             else -- Attribute_Name (N) = Name_Last
 524                return Type_High_Bound (Xtyp);
 525             end if;
 526          end if;
 527
 528          return N;
 529       end Compare_Fixup;
 530
 531       -------------------
 532       -- Is_Same_Value --
 533       -------------------
 534
 535       function Is_Same_Value (L, R : Node_Id) return Boolean is
 536          Lf : constant Node_Id := Compare_Fixup (L);
 537          Rf : constant Node_Id := Compare_Fixup (R);
 538
 539          function Is_Same_Subscript (L, R : List_Id) return Boolean;
 540          --  L, R are the Expressions values from two attribute nodes
 541          --  for First or Last attributes. Either may be set to No_List
 542          --  if no expressions are present (indicating subscript 1).
 543          --  The result is True if both expressions represent the same
 544          --  subscript (note that one case is where one subscript is
 545          --  missing and the other is explicitly set to 1).
 546
 547          -----------------------
 548          -- Is_Same_Subscript --
 549          -----------------------
 550
 551          function Is_Same_Subscript (L, R : List_Id) return Boolean is
 552          begin
 553             if L = No_List then
 554                if R = No_List then
 555                   return True;
 556                else
 557                   return Expr_Value (First (R)) = Uint_1;
 558                end if;
 559
 560             else
 561                if R = No_List then
 562                   return Expr_Value (First (L)) = Uint_1;
 563                else
 564                   return Expr_Value (First (L)) = Expr_Value (First (R));
 565                end if;
 566             end if;
 567          end Is_Same_Subscript;
 568
 569       --  Start of processing for Is_Same_Value
 570
 571       begin
 572          --  Values are the same if they are the same identifier and the
 573          --  identifier refers to a constant object (E_Constant). This
 574          --  does not however apply to Float types, since we may have two
 575          --  NaN values and they should never compare equal.
 576
 577          if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
 578            and then Entity (Lf) = Entity (Rf)
 579            and then not Is_Floating_Point_Type (Etype (L))
 580            and then (Ekind (Entity (Lf)) = E_Constant     or else
 581                      Ekind (Entity (Lf)) = E_In_Parameter or else
 582                      Ekind (Entity (Lf)) = E_Loop_Parameter)
 583          then
 584             return True;
 585
 586          --  Or if they are compile time known and identical
 587
 588          elsif Compile_Time_Known_Value (Lf)
 589                  and then
 590                Compile_Time_Known_Value (Rf)
 591            and then Expr_Value (Lf) = Expr_Value (Rf)
 592          then
 593             return True;
 594
 595          --  Or if they are both 'First or 'Last values applying to the
 596          --  same entity (first and last don't change even if value does)
 597
 598          elsif Nkind (Lf) = N_Attribute_Reference
 599                  and then
 600                Nkind (Rf) = N_Attribute_Reference
 601            and then Attribute_Name (Lf) = Attribute_Name (Rf)
 602            and then (Attribute_Name (Lf) = Name_First
 603                        or else
 604                      Attribute_Name (Lf) = Name_Last)
 605            and then Is_Entity_Name (Prefix (Lf))
 606            and then Is_Entity_Name (Prefix (Rf))
 607            and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
 608            and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
 609          then
 610             return True;
 611
 612          --  All other cases, we can't tell
 613
 614          else
 615             return False;
 616          end if;
 617       end Is_Same_Value;
 618
 619    --  Start of processing for Compile_Time_Compare
 620
 621    begin
 622       --  If either operand could raise constraint error, then we cannot
 623       --  know the result at compile time (since CE may be raised!)
 624
 625       if not (Cannot_Raise_Constraint_Error (L)
 626                 and then
 627               Cannot_Raise_Constraint_Error (R))
 628       then
 629          return Unknown;
 630       end if;
 631
 632       --  Identical operands are most certainly equal
 633
 634       if L = R then
 635          return EQ;
 636
 637       --  If expressions have no types, then do not attempt to determine
 638       --  if they are the same, since something funny is going on. One
 639       --  case in which this happens is during generic template analysis,
 640       --  when bounds are not fully analyzed.
 641
 642       elsif No (Ltyp) or else No (Rtyp) then
 643          return Unknown;
 644
 645       --  We only attempt compile time analysis for scalar values, and
 646       --  not for packed arrays represented as modular types, where the
 647       --  semantics of comparison is quite different.
 648
 649       elsif not Is_Scalar_Type (Ltyp)
 650         or else Is_Packed_Array_Type (Ltyp)
 651       then
 652          return Unknown;
 653
 654       --  Case where comparison involves two compile time known values
 655
 656       elsif Compile_Time_Known_Value (L)
 657         and then Compile_Time_Known_Value (R)
 658       then
 659          --  For the floating-point case, we have to be a little careful, since
 660          --  at compile time we are dealing with universal exact values, but at
 661          --  runtime, these will be in non-exact target form. That's why the
 662          --  returned results are LE and GE below instead of LT and GT.
 663
 664          if Is_Floating_Point_Type (Ltyp)
 665               or else
 666             Is_Floating_Point_Type (Rtyp)
 667          then
 668             declare
 669                Lo : constant Ureal := Expr_Value_R (L);
 670                Hi : constant Ureal := Expr_Value_R (R);
 671
 672             begin
 673                if Lo < Hi then
 674                   return LE;
 675                elsif Lo = Hi then
 676                   return EQ;
 677                else
 678                   return GE;
 679                end if;
 680             end;
 681
 682          --  For the integer case we know exactly (note that this includes the
 683          --  fixed-point case, where we know the run time integer values now)
 684
 685          else
 686             declare
 687                Lo : constant Uint := Expr_Value (L);
 688                Hi : constant Uint := Expr_Value (R);
 689
 690             begin
 691                if Lo < Hi then
 692                   return LT;
 693                elsif Lo = Hi then
 694                   return EQ;
 695                else
 696                   return GT;
 697                end if;
 698             end;
 699          end if;
 700
 701       --  Cases where at least one operand is not known at compile time
 702
 703       else
 704          --  Here is where we check for comparisons against maximum bounds of
 705          --  types, where we know that no value can be outside the bounds of
 706          --  the subtype. Note that this routine is allowed to assume that all
 707          --  expressions are within their subtype bounds. Callers wishing to
 708          --  deal with possibly invalid values must in any case take special
 709          --  steps (e.g. conversions to larger types) to avoid this kind of
 710          --  optimization, which is always considered to be valid. We do not
 711          --  attempt this optimization with generic types, since the type
 712          --  bounds may not be meaningful in this case.
 713
 714          --  We are in danger of an infinite recursion here. It does not seem
 715          --  useful to go more than one level deep, so the parameter Rec is
 716          --  used to protect ourselves against this infinite recursion.
 717
 718          if not Rec
 719            and then Is_Discrete_Type (Ltyp)
 720            and then Is_Discrete_Type (Rtyp)
 721            and then not Is_Generic_Type (Ltyp)
 722            and then not Is_Generic_Type (Rtyp)
 723          then
 724             --  See if we can get a decisive check against one operand and
 725             --  a bound of the other operand (four possible tests here).
 726
 727             case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is
 728                when LT => return LT;
 729                when LE => return LE;
 730                when EQ => return LE;
 731                when others => null;
 732             end case;
 733
 734             case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is
 735                when GT => return GT;
 736                when GE => return GE;
 737                when EQ => return GE;
 738                when others => null;
 739             end case;
 740
 741             case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is
 742                when GT => return GT;
 743                when GE => return GE;
 744                when EQ => return GE;
 745                when others => null;
 746             end case;
 747
 748             case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is
 749                when LT => return LT;
 750                when LE => return LE;
 751                when EQ => return LE;
 752                when others => null;
 753             end case;
 754          end if;
 755
 756          --  Next attempt is to decompose the expressions to extract
 757          --  a constant offset resulting from the use of any of the forms:
 758
 759          --     expr + literal
 760          --     expr - literal
 761          --     typ'Succ (expr)
 762          --     typ'Pred (expr)
 763
 764          --  Then we see if the two expressions are the same value, and if so
 765          --  the result is obtained by comparing the offsets.
 766
 767          declare
 768             Lnode : Node_Id;
 769             Loffs : Uint;
 770             Rnode : Node_Id;
 771             Roffs : Uint;
 772
 773          begin
 774             Compare_Decompose (L, Lnode, Loffs);
 775             Compare_Decompose (R, Rnode, Roffs);
 776
 777             if Is_Same_Value (Lnode, Rnode) then
 778                if Loffs = Roffs then
 779                   return EQ;
 780
 781                elsif Loffs < Roffs then
 782                   return LT;
 783
 784                else
 785                   return GT;
 786                end if;
 787
 788             --  If the expressions are different, we cannot say at compile
 789             --  time how they compare, so we return the Unknown indication.
 790
 791             else
 792                return Unknown;
 793             end if;
 794          end;
 795       end if;
 796    end Compile_Time_Compare;
 797
 798    ------------------------------
 799    -- Compile_Time_Known_Value --
 800    ------------------------------
 801
 802    function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
 803       K      : constant Node_Kind := Nkind (Op);
 804       CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
 805
 806    begin
 807       --  Never known at compile time if bad type or raises constraint error
 808       --  or empty (latter case occurs only as a result of a previous error)
 809
 810       if No (Op)
 811         or else Op = Error
 812         or else Etype (Op) = Any_Type
 813         or else Raises_Constraint_Error (Op)
 814       then
 815          return False;
 816       end if;
 817
 818       --  If this is not a static expression and we are in configurable run
 819       --  time mode, then we consider it not known at compile time. This
 820       --  avoids anomalies where whether something is permitted with a given
 821       --  configurable run-time library depends on how good the compiler is
 822       --  at optimizing and knowing that things are constant when they
 823       --  are non-static.
 824
 825       if Configurable_Run_Time_Mode and then not Is_Static_Expression (Op) then
 826          return False;
 827       end if;
 828
 829       --  If we have an entity name, then see if it is the name of a constant
 830       --  and if so, test the corresponding constant value, or the name of
 831       --  an enumeration literal, which is always a constant.
 832
 833       if Present (Etype (Op)) and then Is_Entity_Name (Op) then
 834          declare
 835             E : constant Entity_Id := Entity (Op);
 836             V : Node_Id;
 837
 838          begin
 839             --  Never known at compile time if it is a packed array value.
 840             --  We might want to try to evaluate these at compile time one
 841             --  day, but we do not make that attempt now.
 842
 843             if Is_Packed_Array_Type (Etype (Op)) then
 844                return False;
 845             end if;
 846
 847             if Ekind (E) = E_Enumeration_Literal then
 848                return True;
 849
 850             elsif Ekind (E) = E_Constant then
 851                V := Constant_Value (E);
 852                return Present (V) and then Compile_Time_Known_Value (V);
 853             end if;
 854          end;
 855
 856       --  We have a value, see if it is compile time known
 857
 858       else
 859          --  Integer literals are worth storing in the cache
 860
 861          if K = N_Integer_Literal then
 862             CV_Ent.N := Op;
 863             CV_Ent.V := Intval (Op);
 864             return True;
 865
 866          --  Other literals and NULL are known at compile time
 867
 868          elsif
 869             K = N_Character_Literal
 870               or else
 871             K = N_Real_Literal
 872               or else
 873             K = N_String_Literal
 874               or else
 875             K = N_Null
 876          then
 877             return True;
 878
 879          --  Any reference to Null_Parameter is known at compile time. No
 880          --  other attribute references (that have not already been folded)
 881          --  are known at compile time.
 882
 883          elsif K = N_Attribute_Reference then
 884             return Attribute_Name (Op) = Name_Null_Parameter;
 885          end if;
 886       end if;
 887
 888       --  If we fall through, not known at compile time
 889
 890       return False;
 891
 892    --  If we get an exception while trying to do this test, then some error
 893    --  has occurred, and we simply say that the value is not known after all
 894
 895    exception
 896       when others =>
 897          return False;
 898    end Compile_Time_Known_Value;
 899
 900    --------------------------------------
 901    -- Compile_Time_Known_Value_Or_Aggr --
 902    --------------------------------------
 903
 904    function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
 905    begin
 906       --  If we have an entity name, then see if it is the name of a constant
 907       --  and if so, test the corresponding constant value, or the name of
 908       --  an enumeration literal, which is always a constant.
 909
 910       if Is_Entity_Name (Op) then
 911          declare
 912             E : constant Entity_Id := Entity (Op);
 913             V : Node_Id;
 914
 915          begin
 916             if Ekind (E) = E_Enumeration_Literal then
 917                return True;
 918
 919             elsif Ekind (E) /= E_Constant then
 920                return False;
 921
 922             else
 923                V := Constant_Value (E);
 924                return Present (V)
 925                  and then Compile_Time_Known_Value_Or_Aggr (V);
 926             end if;
 927          end;
 928
 929       --  We have a value, see if it is compile time known
 930
 931       else
 932          if Compile_Time_Known_Value (Op) then
 933             return True;
 934
 935          elsif Nkind (Op) = N_Aggregate then
 936
 937             if Present (Expressions (Op)) then
 938                declare
 939                   Expr : Node_Id;
 940
 941                begin
 942                   Expr := First (Expressions (Op));
 943                   while Present (Expr) loop
 944                      if not Compile_Time_Known_Value_Or_Aggr (Expr) then
 945                         return False;
 946                      end if;
 947
 948                      Next (Expr);
 949                   end loop;
 950                end;
 951             end if;
 952
 953             if Present (Component_Associations (Op)) then
 954                declare
 955                   Cass : Node_Id;
 956
 957                begin
 958                   Cass := First (Component_Associations (Op));
 959                   while Present (Cass) loop
 960                      if not
 961                        Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
 962                      then
 963                         return False;
 964                      end if;
 965
 966                      Next (Cass);
 967                   end loop;
 968                end;
 969             end if;
 970
 971             return True;
 972
 973          --  All other types of values are not known at compile time
 974
 975          else
 976             return False;
 977          end if;
 978
 979       end if;
 980    end Compile_Time_Known_Value_Or_Aggr;
 981
 982    -----------------
 983    -- Eval_Actual --
 984    -----------------
 985
 986    --  This is only called for actuals of functions that are not predefined
 987    --  operators (which have already been rewritten as operators at this
 988    --  stage), so the call can never be folded, and all that needs doing for
 989    --  the actual is to do the check for a non-static context.
 990
 991    procedure Eval_Actual (N : Node_Id) is
 992    begin
 993       Check_Non_Static_Context (N);
 994    end Eval_Actual;
 995
 996    --------------------
 997    -- Eval_Allocator --
 998    --------------------
 999
1000    --  Allocators are never static, so all we have to do is to do the
1001    --  check for a non-static context if an expression is present.
1002
1003    procedure Eval_Allocator (N : Node_Id) is
1004       Expr : constant Node_Id := Expression (N);
1005
1006    begin
1007       if Nkind (Expr) = N_Qualified_Expression then
1008          Check_Non_Static_Context (Expression (Expr));
1009       end if;
1010    end Eval_Allocator;
1011
1012    ------------------------
1013    -- Eval_Arithmetic_Op --
1014    ------------------------
1015
1016    --  Arithmetic operations are static functions, so the result is static
1017    --  if both operands are static (RM 4.9(7), 4.9(20)).
1018
1019    procedure Eval_Arithmetic_Op (N : Node_Id) is
1020       Left  : constant Node_Id   := Left_Opnd (N);
1021       Right : constant Node_Id   := Right_Opnd (N);
1022       Ltype : constant Entity_Id := Etype (Left);
1023       Rtype : constant Entity_Id := Etype (Right);
1024       Stat  : Boolean;
1025       Fold  : Boolean;
1026
1027    begin
1028       --  If not foldable we are done
1029
1030       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1031
1032       if not Fold then
1033          return;
1034       end if;
1035
1036       --  Fold for cases where both operands are of integer type
1037
1038       if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1039          declare
1040             Left_Int  : constant Uint := Expr_Value (Left);
1041             Right_Int : constant Uint := Expr_Value (Right);
1042             Result    : Uint;
1043
1044          begin
1045             case Nkind (N) is
1046
1047                when N_Op_Add =>
1048                   Result := Left_Int + Right_Int;
1049
1050                when N_Op_Subtract =>
1051                   Result := Left_Int - Right_Int;
1052
1053                when N_Op_Multiply =>
1054                   if OK_Bits
1055                        (N, UI_From_Int
1056                              (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1057                   then
1058                      Result := Left_Int * Right_Int;
1059                   else
1060                      Result := Left_Int;
1061                   end if;
1062
1063                when N_Op_Divide =>
1064
1065                   --  The exception Constraint_Error is raised by integer
1066                   --  division, rem and mod if the right operand is zero.
1067
1068                   if Right_Int = 0 then
1069                      Apply_Compile_Time_Constraint_Error
1070                        (N, "division by zero",
1071                         CE_Divide_By_Zero,
1072                         Warn => not Stat);
1073                      return;
1074
1075                   else
1076                      Result := Left_Int / Right_Int;
1077                   end if;
1078
1079                when N_Op_Mod =>
1080
1081                   --  The exception Constraint_Error is raised by integer
1082                   --  division, rem and mod if the right operand is zero.
1083
1084                   if Right_Int = 0 then
1085                      Apply_Compile_Time_Constraint_Error
1086                        (N, "mod with zero divisor",
1087                         CE_Divide_By_Zero,
1088                         Warn => not Stat);
1089                      return;
1090                   else
1091                      Result := Left_Int mod Right_Int;
1092                   end if;
1093
1094                when N_Op_Rem =>
1095
1096                   --  The exception Constraint_Error is raised by integer
1097                   --  division, rem and mod if the right operand is zero.
1098
1099                   if Right_Int = 0 then
1100                      Apply_Compile_Time_Constraint_Error
1101                        (N, "rem with zero divisor",
1102                         CE_Divide_By_Zero,
1103                         Warn => not Stat);
1104                      return;
1105
1106                   else
1107                      Result := Left_Int rem Right_Int;
1108                   end if;
1109
1110                when others =>
1111                   raise Program_Error;
1112             end case;
1113
1114             --  Adjust the result by the modulus if the type is a modular type
1115
1116             if Is_Modular_Integer_Type (Ltype) then
1117                Result := Result mod Modulus (Ltype);
1118             end if;
1119
1120             Fold_Uint (N, Result, Stat);
1121          end;
1122
1123       --  Cases where at least one operand is a real. We handle the cases
1124       --  of both reals, or mixed/real integer cases (the latter happen
1125       --  only for divide and multiply, and the result is always real).
1126
1127       elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1128          declare
1129             Left_Real  : Ureal;
1130             Right_Real : Ureal;
1131             Result     : Ureal;
1132
1133          begin
1134             if Is_Real_Type (Ltype) then
1135                Left_Real := Expr_Value_R (Left);
1136             else
1137                Left_Real := UR_From_Uint (Expr_Value (Left));
1138             end if;
1139
1140             if Is_Real_Type (Rtype) then
1141                Right_Real := Expr_Value_R (Right);
1142             else
1143                Right_Real := UR_From_Uint (Expr_Value (Right));
1144             end if;
1145
1146             if Nkind (N) = N_Op_Add then
1147                Result := Left_Real + Right_Real;
1148
1149             elsif Nkind (N) = N_Op_Subtract then
1150                Result := Left_Real - Right_Real;
1151
1152             elsif Nkind (N) = N_Op_Multiply then
1153                Result := Left_Real * Right_Real;
1154
1155             else pragma Assert (Nkind (N) = N_Op_Divide);
1156                if UR_Is_Zero (Right_Real) then
1157                   Apply_Compile_Time_Constraint_Error
1158                     (N, "division by zero", CE_Divide_By_Zero);
1159                   return;
1160                end if;
1161
1162                Result := Left_Real / Right_Real;
1163             end if;
1164
1165             Fold_Ureal (N, Result, Stat);
1166          end;
1167       end if;
1168    end Eval_Arithmetic_Op;
1169
1170    ----------------------------
1171    -- Eval_Character_Literal --
1172    ----------------------------
1173
1174    --  Nothing to be done!
1175
1176    procedure Eval_Character_Literal (N : Node_Id) is
1177       pragma Warnings (Off, N);
1178
1179    begin
1180       null;
1181    end Eval_Character_Literal;
1182
1183    ------------------------
1184    -- Eval_Concatenation --
1185    ------------------------
1186
1187    --  Concatenation is a static function, so the result is static if
1188    --  both operands are static (RM 4.9(7), 4.9(21)).
1189
1190    procedure Eval_Concatenation (N : Node_Id) is
1191       Left  : constant Node_Id   := Left_Opnd (N);
1192       Right : constant Node_Id   := Right_Opnd (N);
1193       C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
1194       Stat  : Boolean;
1195       Fold  : Boolean;
1196
1197    begin
1198       --  Concatenation is never static in Ada 83, so if Ada 83
1199       --  check operand non-static context
1200
1201       if Ada_83
1202         and then Comes_From_Source (N)
1203       then
1204          Check_Non_Static_Context (Left);
1205          Check_Non_Static_Context (Right);
1206          return;
1207       end if;
1208
1209       --  If not foldable we are done. In principle concatenation that yields
1210       --  any string type is static (i.e. an array type of character types).
1211       --  However, character types can include enumeration literals, and
1212       --  concatenation in that case cannot be described by a literal, so we
1213       --  only consider the operation static if the result is an array of
1214       --  (a descendant of) a predefined character type.
1215
1216       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1217
1218       if (C_Typ = Standard_Character
1219             or else  C_Typ = Standard_Wide_Character)
1220         and then Fold
1221       then
1222          null;
1223       else
1224          Set_Is_Static_Expression (N, False);
1225          return;
1226       end if;
1227
1228       --  Compile time string concatenation.
1229
1230       --  ??? Note that operands that are aggregates can be marked as
1231       --  static, so we should attempt at a later stage to fold
1232       --  concatenations with such aggregates.
1233
1234       declare
1235          Left_Str  : constant Node_Id := Get_String_Val (Left);
1236          Left_Len  : Nat;
1237          Right_Str : constant Node_Id := Get_String_Val (Right);
1238
1239       begin
1240          --  Establish new string literal, and store left operand. We make
1241          --  sure to use the special Start_String that takes an operand if
1242          --  the left operand is a string literal. Since this is optimized
1243          --  in the case where that is the most recently created string
1244          --  literal, we ensure efficient time/space behavior for the
1245          --  case of a concatenation of a series of string literals.
1246
1247          if Nkind (Left_Str) = N_String_Literal then
1248             Left_Len :=  String_Length (Strval (Left_Str));
1249             Start_String (Strval (Left_Str));
1250          else
1251             Start_String;
1252             Store_String_Char (Char_Literal_Value (Left_Str));
1253             Left_Len := 1;
1254          end if;
1255
1256          --  Now append the characters of the right operand
1257
1258          if Nkind (Right_Str) = N_String_Literal then
1259             declare
1260                S : constant String_Id := Strval (Right_Str);
1261
1262             begin
1263                for J in 1 .. String_Length (S) loop
1264                   Store_String_Char (Get_String_Char (S, J));
1265                end loop;
1266             end;
1267          else
1268             Store_String_Char (Char_Literal_Value (Right_Str));
1269          end if;
1270
1271          Set_Is_Static_Expression (N, Stat);
1272
1273          if Stat then
1274
1275             --  If left operand is the empty string, the result is the
1276             --  right operand, including its bounds if anomalous.
1277
1278             if Left_Len = 0
1279               and then Is_Array_Type (Etype (Right))
1280               and then Etype (Right) /= Any_String
1281             then
1282                Set_Etype (N, Etype (Right));
1283             end if;
1284
1285             Fold_Str (N, End_String, True);
1286          end if;
1287       end;
1288    end Eval_Concatenation;
1289
1290    ---------------------------------
1291    -- Eval_Conditional_Expression --
1292    ---------------------------------
1293
1294    --  This GNAT internal construct can never be statically folded, so the
1295    --  only required processing is to do the check for non-static context
1296    --  for the two expression operands.
1297
1298    procedure Eval_Conditional_Expression (N : Node_Id) is
1299       Condition : constant Node_Id := First (Expressions (N));
1300       Then_Expr : constant Node_Id := Next (Condition);
1301       Else_Expr : constant Node_Id := Next (Then_Expr);
1302
1303    begin
1304       Check_Non_Static_Context (Then_Expr);
1305       Check_Non_Static_Context (Else_Expr);
1306    end Eval_Conditional_Expression;
1307
1308    ----------------------
1309    -- Eval_Entity_Name --
1310    ----------------------
1311
1312    --  This procedure is used for identifiers and expanded names other than
1313    --  named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1314    --  static if they denote a static constant (RM 4.9(6)) or if the name
1315    --  denotes an enumeration literal (RM 4.9(22)).
1316
1317    procedure Eval_Entity_Name (N : Node_Id) is
1318       Def_Id : constant Entity_Id := Entity (N);
1319       Val    : Node_Id;
1320
1321    begin
1322       --  Enumeration literals are always considered to be constants
1323       --  and cannot raise constraint error (RM 4.9(22)).
1324
1325       if Ekind (Def_Id) = E_Enumeration_Literal then
1326          Set_Is_Static_Expression (N);
1327          return;
1328
1329       --  A name is static if it denotes a static constant (RM 4.9(5)), and
1330       --  we also copy Raise_Constraint_Error. Notice that even if non-static,
1331       --  it does not violate 10.2.1(8) here, since this is not a variable.
1332
1333       elsif Ekind (Def_Id) = E_Constant then
1334
1335          --  Deferred constants must always be treated as nonstatic
1336          --  outside the scope of their full view.
1337
1338          if Present (Full_View (Def_Id))
1339            and then not In_Open_Scopes (Scope (Def_Id))
1340          then
1341             Val := Empty;
1342          else
1343             Val := Constant_Value (Def_Id);
1344          end if;
1345
1346          if Present (Val) then
1347             Set_Is_Static_Expression
1348               (N, Is_Static_Expression (Val)
1349                     and then Is_Static_Subtype (Etype (Def_Id)));
1350             Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1351
1352             if not Is_Static_Expression (N)
1353               and then not Is_Generic_Type (Etype (N))
1354             then
1355                Validate_Static_Object_Name (N);
1356             end if;
1357
1358             return;
1359          end if;
1360       end if;
1361
1362       --  Fall through if the name is not static.
1363
1364       Validate_Static_Object_Name (N);
1365    end Eval_Entity_Name;
1366
1367    ----------------------------
1368    -- Eval_Indexed_Component --
1369    ----------------------------
1370
1371    --  Indexed components are never static, so we need to perform the check
1372    --  for non-static context on the index values. Then, we check if the
1373    --  value can be obtained at compile time, even though it is non-static.
1374
1375    procedure Eval_Indexed_Component (N : Node_Id) is
1376       Expr : Node_Id;
1377
1378    begin
1379       --  Check for non-static context on index values
1380
1381       Expr := First (Expressions (N));
1382       while Present (Expr) loop
1383          Check_Non_Static_Context (Expr);
1384          Next (Expr);
1385       end loop;
1386
1387       --  If the indexed component appears in an object renaming declaration
1388       --  then we do not want to try to evaluate it, since in this case we
1389       --  need the identity of the array element.
1390
1391       if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
1392          return;
1393
1394       --  Similarly if the indexed component appears as the prefix of an
1395       --  attribute we don't want to evaluate it, because at least for
1396       --  some cases of attributes we need the identify (e.g. Access, Size)
1397
1398       elsif Nkind (Parent (N)) = N_Attribute_Reference then
1399          return;
1400       end if;
1401
1402       --  Note: there are other cases, such as the left side of an assignment,
1403       --  or an OUT parameter for a call, where the replacement results in the
1404       --  illegal use of a constant, But these cases are illegal in the first
1405       --  place, so the replacement, though silly, is harmless.
1406
1407       --  Now see if this is a constant array reference
1408
1409       if List_Length (Expressions (N)) = 1
1410         and then Is_Entity_Name (Prefix (N))
1411         and then Ekind (Entity (Prefix (N))) = E_Constant
1412         and then Present (Constant_Value (Entity (Prefix (N))))
1413       then
1414          declare
1415             Loc : constant Source_Ptr := Sloc (N);
1416             Arr : constant Node_Id    := Constant_Value (Entity (Prefix (N)));
1417             Sub : constant Node_Id    := First (Expressions (N));
1418
1419             Atyp : Entity_Id;
1420             --  Type of array
1421
1422             Lin : Nat;
1423             --  Linear one's origin subscript value for array reference
1424
1425             Lbd : Node_Id;
1426             --  Lower bound of the first array index
1427
1428             Elm : Node_Id;
1429             --  Value from constant array
1430
1431          begin
1432             Atyp := Etype (Arr);
1433
1434             if Is_Access_Type (Atyp) then
1435                Atyp := Designated_Type (Atyp);
1436             end if;
1437
1438             --  If we have an array type (we should have but perhaps there
1439             --  are error cases where this is not the case), then see if we
1440             --  can do a constant evaluation of the array reference.
1441
1442             if Is_Array_Type (Atyp) then
1443                if Ekind (Atyp) = E_String_Literal_Subtype then
1444                   Lbd := String_Literal_Low_Bound (Atyp);
1445                else
1446                   Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
1447                end if;
1448
1449                if Compile_Time_Known_Value (Sub)
1450                  and then Nkind (Arr) = N_Aggregate
1451                  and then Compile_Time_Known_Value (Lbd)
1452                  and then Is_Discrete_Type (Component_Type (Atyp))
1453                then
1454                   Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
1455
1456                   if List_Length (Expressions (Arr)) >= Lin then
1457                      Elm := Pick (Expressions (Arr), Lin);
1458
1459                      --  If the resulting expression is compile time known,
1460                      --  then we can rewrite the indexed component with this
1461                      --  value, being sure to mark the result as non-static.
1462                      --  We also reset the Sloc, in case this generates an
1463                      --  error later on (e.g. 136'Access).
1464
1465                      if Compile_Time_Known_Value (Elm) then
1466                         Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
1467                         Set_Is_Static_Expression (N, False);
1468                         Set_Sloc (N, Loc);
1469                      end if;
1470                   end if;
1471                end if;
1472             end if;
1473          end;
1474       end if;
1475    end Eval_Indexed_Component;
1476
1477    --------------------------
1478    -- Eval_Integer_Literal --
1479    --------------------------
1480
1481    --  Numeric literals are static (RM 4.9(1)), and have already been marked
1482    --  as static by the analyzer. The reason we did it that early is to allow
1483    --  the possibility of turning off the Is_Static_Expression flag after
1484    --  analysis, but before resolution, when integer literals are generated
1485    --  in the expander that do not correspond to static expressions.
1486
1487    procedure Eval_Integer_Literal (N : Node_Id) is
1488       T : constant Entity_Id := Etype (N);
1489
1490    begin
1491       --  If the literal appears in a non-expression context, then it is
1492       --  certainly appearing in a non-static context, so check it. This
1493       --  is actually a redundant check, since Check_Non_Static_Context
1494       --  would check it, but it seems worth while avoiding the call.
1495
1496       if Nkind (Parent (N)) not in N_Subexpr then
1497          Check_Non_Static_Context (N);
1498       end if;
1499
1500       --  Modular integer literals must be in their base range
1501
1502       if Is_Modular_Integer_Type (T)
1503         and then Is_Out_Of_Range (N, Base_Type (T))
1504       then
1505          Out_Of_Range (N);
1506       end if;
1507    end Eval_Integer_Literal;
1508
1509    ---------------------
1510    -- Eval_Logical_Op --
1511    ---------------------
1512
1513    --  Logical operations are static functions, so the result is potentially
1514    --  static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1515
1516    procedure Eval_Logical_Op (N : Node_Id) is
1517       Left  : constant Node_Id := Left_Opnd (N);
1518       Right : constant Node_Id := Right_Opnd (N);
1519       Stat  : Boolean;
1520       Fold  : Boolean;
1521
1522    begin
1523       --  If not foldable we are done
1524
1525       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1526
1527       if not Fold then
1528          return;
1529       end if;
1530
1531       --  Compile time evaluation of logical operation
1532
1533       declare
1534          Left_Int  : constant Uint := Expr_Value (Left);
1535          Right_Int : constant Uint := Expr_Value (Right);
1536
1537       begin
1538          if Is_Modular_Integer_Type (Etype (N)) then
1539             declare
1540                Left_Bits  : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1541                Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
1542
1543             begin
1544                To_Bits (Left_Int, Left_Bits);
1545                To_Bits (Right_Int, Right_Bits);
1546
1547                --  Note: should really be able to use array ops instead of
1548                --  these loops, but they weren't working at the time ???
1549
1550                if Nkind (N) = N_Op_And then
1551                   for J in Left_Bits'Range loop
1552                      Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
1553                   end loop;
1554
1555                elsif Nkind (N) = N_Op_Or then
1556                   for J in Left_Bits'Range loop
1557                      Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
1558                   end loop;
1559
1560                else
1561                   pragma Assert (Nkind (N) = N_Op_Xor);
1562
1563                   for J in Left_Bits'Range loop
1564                      Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
1565                   end loop;
1566                end if;
1567
1568                Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
1569             end;
1570
1571          else
1572             pragma Assert (Is_Boolean_Type (Etype (N)));
1573
1574             if Nkind (N) = N_Op_And then
1575                Fold_Uint (N,
1576                  Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
1577
1578             elsif Nkind (N) = N_Op_Or then
1579                Fold_Uint (N,
1580                  Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
1581
1582             else
1583                pragma Assert (Nkind (N) = N_Op_Xor);
1584                Fold_Uint (N,
1585                  Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
1586             end if;
1587          end if;
1588       end;
1589    end Eval_Logical_Op;
1590
1591    ------------------------
1592    -- Eval_Membership_Op --
1593    ------------------------
1594
1595    --  A membership test is potentially static if the expression is static,
1596    --  and the range is a potentially static range, or is a subtype mark
1597    --  denoting a static subtype (RM 4.9(12)).
1598
1599    procedure Eval_Membership_Op (N : Node_Id) is
1600       Left   : constant Node_Id := Left_Opnd (N);
1601       Right  : constant Node_Id := Right_Opnd (N);
1602       Def_Id : Entity_Id;
1603       Lo     : Node_Id;
1604       Hi     : Node_Id;
1605       Result : Boolean;
1606       Stat   : Boolean;
1607       Fold   : Boolean;
1608
1609    begin
1610       --  Ignore if error in either operand, except to make sure that
1611       --  Any_Type is properly propagated to avoid junk cascaded errors.
1612
1613       if Etype (Left) = Any_Type
1614         or else Etype (Right) = Any_Type
1615       then
1616          Set_Etype (N, Any_Type);
1617          return;
1618       end if;
1619
1620       --  Case of right operand is a subtype name
1621
1622       if Is_Entity_Name (Right) then
1623          Def_Id := Entity (Right);
1624
1625          if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
1626            and then Is_OK_Static_Subtype (Def_Id)
1627          then
1628             Test_Expression_Is_Foldable (N, Left, Stat, Fold);
1629
1630             if not Fold or else not Stat then
1631                return;
1632             end if;
1633          else
1634             Check_Non_Static_Context (Left);
1635             return;
1636          end if;
1637
1638          --  For string membership tests we will check the length
1639          --  further below.
1640
1641          if not Is_String_Type (Def_Id) then
1642             Lo := Type_Low_Bound (Def_Id);
1643             Hi := Type_High_Bound (Def_Id);
1644
1645          else
1646             Lo := Empty;
1647             Hi := Empty;
1648          end if;
1649
1650       --  Case of right operand is a range
1651
1652       else
1653          if Is_Static_Range (Right) then
1654             Test_Expression_Is_Foldable (N, Left, Stat, Fold);
1655
1656             if not Fold or else not Stat then
1657                return;
1658
1659             --  If one bound of range raises CE, then don't try to fold
1660
1661             elsif not Is_OK_Static_Range (Right) then
1662                Check_Non_Static_Context (Left);
1663                return;
1664             end if;
1665
1666          else
1667             Check_Non_Static_Context (Left);
1668             return;
1669          end if;
1670
1671          --  Here we know range is an OK static range
1672
1673          Lo := Low_Bound (Right);
1674          Hi := High_Bound (Right);
1675       end if;
1676
1677       --  For strings we check that the length of the string expression is
1678       --  compatible with the string subtype if the subtype is constrained,
1679       --  or if unconstrained then the test is always true.
1680
1681       if Is_String_Type (Etype (Right)) then
1682          if not Is_Constrained (Etype (Right)) then
1683             Result := True;
1684
1685          else
1686             declare
1687                Typlen : constant Uint := String_Type_Len (Etype (Right));
1688                Strlen : constant Uint :=
1689                  UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
1690             begin
1691                Result := (Typlen = Strlen);
1692             end;
1693          end if;
1694
1695       --  Fold the membership test. We know we have a static range and Lo
1696       --  and Hi are set to the expressions for the end points of this range.
1697
1698       elsif Is_Real_Type (Etype (Right)) then
1699          declare
1700             Leftval : constant Ureal := Expr_Value_R (Left);
1701
1702          begin
1703             Result := Expr_Value_R (Lo) <= Leftval
1704                         and then Leftval <= Expr_Value_R (Hi);
1705          end;
1706
1707       else
1708          declare
1709             Leftval : constant Uint := Expr_Value (Left);
1710
1711          begin
1712             Result := Expr_Value (Lo) <= Leftval
1713                         and then Leftval <= Expr_Value (Hi);
1714          end;
1715       end if;
1716
1717       if Nkind (N) = N_Not_In then
1718          Result := not Result;
1719       end if;
1720
1721       Fold_Uint (N, Test (Result), True);
1722       Warn_On_Known_Condition (N);
1723    end Eval_Membership_Op;
1724
1725    ------------------------
1726    -- Eval_Named_Integer --
1727    ------------------------
1728
1729    procedure Eval_Named_Integer (N : Node_Id) is
1730    begin
1731       Fold_Uint (N,
1732         Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
1733    end Eval_Named_Integer;
1734
1735    ---------------------
1736    -- Eval_Named_Real --
1737    ---------------------
1738
1739    procedure Eval_Named_Real (N : Node_Id) is
1740    begin
1741       Fold_Ureal (N,
1742         Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
1743    end Eval_Named_Real;
1744
1745    -------------------
1746    -- Eval_Op_Expon --
1747    -------------------
1748
1749    --  Exponentiation is a static functions, so the result is potentially
1750    --  static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1751
1752    procedure Eval_Op_Expon (N : Node_Id) is
1753       Left  : constant Node_Id := Left_Opnd (N);
1754       Right : constant Node_Id := Right_Opnd (N);
1755       Stat  : Boolean;
1756       Fold  : Boolean;
1757
1758    begin
1759       --  If not foldable we are done
1760
1761       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1762
1763       if not Fold then
1764          return;
1765       end if;
1766
1767       --  Fold exponentiation operation
1768
1769       declare
1770          Right_Int : constant Uint := Expr_Value (Right);
1771
1772       begin
1773          --  Integer case
1774
1775          if Is_Integer_Type (Etype (Left)) then
1776             declare
1777                Left_Int : constant Uint := Expr_Value (Left);
1778                Result   : Uint;
1779
1780             begin
1781                --  Exponentiation of an integer raises the exception
1782                --  Constraint_Error for a negative exponent (RM 4.5.6)
1783
1784                if Right_Int < 0 then
1785                   Apply_Compile_Time_Constraint_Error
1786                     (N, "integer exponent negative",
1787                      CE_Range_Check_Failed,
1788                      Warn => not Stat);
1789                   return;
1790
1791                else
1792                   if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
1793                      Result := Left_Int ** Right_Int;
1794                   else
1795                      Result := Left_Int;
1796                   end if;
1797
1798                   if Is_Modular_Integer_Type (Etype (N)) then
1799                      Result := Result mod Modulus (Etype (N));
1800                   end if;
1801
1802                   Fold_Uint (N, Result, Stat);
1803                end if;
1804             end;
1805
1806          --  Real case
1807
1808          else
1809             declare
1810                Left_Real : constant Ureal := Expr_Value_R (Left);
1811
1812             begin
1813                --  Cannot have a zero base with a negative exponent
1814
1815                if UR_Is_Zero (Left_Real) then
1816
1817                   if Right_Int < 0 then
1818                      Apply_Compile_Time_Constraint_Error
1819                        (N, "zero ** negative integer",
1820                         CE_Range_Check_Failed,
1821                         Warn => not Stat);
1822                      return;
1823                   else
1824                      Fold_Ureal (N, Ureal_0, Stat);
1825                   end if;
1826
1827                else
1828                   Fold_Ureal (N, Left_Real ** Right_Int, Stat);
1829                end if;
1830             end;
1831          end if;
1832       end;
1833    end Eval_Op_Expon;
1834
1835    -----------------
1836    -- Eval_Op_Not --
1837    -----------------
1838
1839    --  The not operation is a  static functions, so the result is potentially
1840    --  static if the operand is potentially static (RM 4.9(7), 4.9(20)).
1841
1842    procedure Eval_Op_Not (N : Node_Id) is
1843       Right : constant Node_Id := Right_Opnd (N);
1844       Stat  : Boolean;
1845       Fold  : Boolean;
1846
1847    begin
1848       --  If not foldable we are done
1849
1850       Test_Expression_Is_Foldable (N, Right, Stat, Fold);
1851
1852       if not Fold then
1853          return;
1854       end if;
1855
1856       --  Fold not operation
1857
1858       declare
1859          Rint : constant Uint      := Expr_Value (Right);
1860          Typ  : constant Entity_Id := Etype (N);
1861
1862       begin
1863          --  Negation is equivalent to subtracting from the modulus minus
1864          --  one. For a binary modulus this is equivalent to the ones-
1865          --  component of the original value. For non-binary modulus this
1866          --  is an arbitrary but consistent definition.
1867
1868          if Is_Modular_Integer_Type (Typ) then
1869             Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
1870
1871          else
1872             pragma Assert (Is_Boolean_Type (Typ));
1873             Fold_Uint (N, Test (not Is_True (Rint)), Stat);
1874          end if;
1875
1876          Set_Is_Static_Expression (N, Stat);
1877       end;
1878    end Eval_Op_Not;
1879
1880    -------------------------------
1881    -- Eval_Qualified_Expression --
1882    -------------------------------
1883
1884    --  A qualified expression is potentially static if its subtype mark denotes
1885    --  a static subtype and its expression is potentially static (RM 4.9 (11)).
1886
1887    procedure Eval_Qualified_Expression (N : Node_Id) is
1888       Operand     : constant Node_Id   := Expression (N);
1889       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
1890
1891       Stat : Boolean;
1892       Fold : Boolean;
1893       Hex  : Boolean;
1894
1895    begin
1896       --  Can only fold if target is string or scalar and subtype is static
1897       --  Also, do not fold if our parent is an allocator (this is because
1898       --  the qualified expression is really part of the syntactic structure
1899       --  of an allocator, and we do not want to end up with something that
1900       --  corresponds to "new 1" where the 1 is the result of folding a
1901       --  qualified expression).
1902
1903       if not Is_Static_Subtype (Target_Type)
1904         or else Nkind (Parent (N)) = N_Allocator
1905       then
1906          Check_Non_Static_Context (Operand);
1907          return;
1908       end if;
1909
1910       --  If not foldable we are done
1911
1912       Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
1913
1914       if not Fold then
1915          return;
1916
1917       --  Don't try fold if target type has constraint error bounds
1918
1919       elsif not Is_OK_Static_Subtype (Target_Type) then
1920          Set_Raises_Constraint_Error (N);
1921          return;
1922       end if;
1923
1924       --  Here we will fold, save Print_In_Hex indication
1925
1926       Hex := Nkind (Operand) = N_Integer_Literal
1927                and then Print_In_Hex (Operand);
1928
1929       --  Fold the result of qualification
1930
1931       if Is_Discrete_Type (Target_Type) then
1932          Fold_Uint (N, Expr_Value (Operand), Stat);
1933
1934          --  Preserve Print_In_Hex indication
1935
1936          if Hex and then Nkind (N) = N_Integer_Literal then
1937             Set_Print_In_Hex (N);
1938          end if;
1939
1940       elsif Is_Real_Type (Target_Type) then
1941          Fold_Ureal (N, Expr_Value_R (Operand), Stat);
1942
1943       else
1944          Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
1945
1946          if not Stat then
1947             Set_Is_Static_Expression (N, False);
1948          else
1949             Check_String_Literal_Length (N, Target_Type);
1950          end if;
1951
1952          return;
1953       end if;
1954
1955       --  The expression may be foldable but not static
1956
1957       Set_Is_Static_Expression (N, Stat);
1958
1959       if Is_Out_Of_Range (N, Etype (N)) then
1960          Out_Of_Range (N);
1961       end if;
1962    end Eval_Qualified_Expression;
1963
1964    -----------------------
1965    -- Eval_Real_Literal --
1966    -----------------------
1967
1968    --  Numeric literals are static (RM 4.9(1)), and have already been marked
1969    --  as static by the analyzer. The reason we did it that early is to allow
1970    --  the possibility of turning off the Is_Static_Expression flag after
1971    --  analysis, but before resolution, when integer literals are generated
1972    --  in the expander that do not correspond to static expressions.
1973
1974    procedure Eval_Real_Literal (N : Node_Id) is
1975    begin
1976       --  If the literal appears in a non-expression context, then it is
1977       --  certainly appearing in a non-static context, so check it.
1978
1979       if Nkind (Parent (N)) not in N_Subexpr then
1980          Check_Non_Static_Context (N);
1981       end if;
1982
1983    end Eval_Real_Literal;
1984
1985    ------------------------
1986    -- Eval_Relational_Op --
1987    ------------------------
1988
1989    --  Relational operations are static functions, so the result is static
1990    --  if both operands are static (RM 4.9(7), 4.9(20)).
1991
1992    procedure Eval_Relational_Op (N : Node_Id) is
1993       Left   : constant Node_Id   := Left_Opnd (N);
1994       Right  : constant Node_Id   := Right_Opnd (N);
1995       Typ    : constant Entity_Id := Etype (Left);
1996       Result : Boolean;
1997       Stat   : Boolean;
1998       Fold   : Boolean;
1999
2000    begin
2001       --  One special case to deal with first. If we can tell that
2002       --  the result will be false because the lengths of one or
2003       --  more index subtypes are compile time known and different,
2004       --  then we can replace the entire result by False. We only
2005       --  do this for one dimensional arrays, because the case of
2006       --  multi-dimensional arrays is rare and too much trouble!
2007
2008       if Is_Array_Type (Typ)
2009         and then Number_Dimensions (Typ) = 1
2010         and then (Nkind (N) = N_Op_Eq
2011                     or else Nkind (N) = N_Op_Ne)
2012       then
2013          if Raises_Constraint_Error (Left)
2014            or else Raises_Constraint_Error (Right)
2015          then
2016             return;
2017          end if;
2018
2019          declare
2020             procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
2021             --  If Op is an expression for a constrained array with a
2022             --  known at compile time length, then Len is set to this
2023             --  (non-negative length). Otherwise Len is set to minus 1.
2024
2025             -----------------------
2026             -- Get_Static_Length --
2027             -----------------------
2028
2029             procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2030                T : Entity_Id;
2031
2032             begin
2033                if Nkind (Op) = N_String_Literal then
2034                   Len := UI_From_Int (String_Length (Strval (Op)));
2035
2036                elsif not Is_Constrained (Etype (Op)) then
2037                   Len := Uint_Minus_1;
2038
2039                else
2040                   T := Etype (First_Index (Etype (Op)));
2041
2042                   if Is_Discrete_Type (T)
2043                     and then
2044                       Compile_Time_Known_Value (Type_Low_Bound (T))
2045                     and then
2046                       Compile_Time_Known_Value (Type_High_Bound (T))
2047                   then
2048                      Len := UI_Max (Uint_0,
2049                                      Expr_Value (Type_High_Bound (T)) -
2050                                      Expr_Value (Type_Low_Bound  (T)) + 1);
2051                   else
2052                      Len := Uint_Minus_1;
2053                   end if;
2054                end if;
2055             end Get_Static_Length;
2056
2057             Len_L : Uint;
2058             Len_R : Uint;
2059
2060          begin
2061             Get_Static_Length (Left,  Len_L);
2062             Get_Static_Length (Right, Len_R);
2063
2064             if Len_L /= Uint_Minus_1
2065               and then Len_R /= Uint_Minus_1
2066               and then Len_L /= Len_R
2067             then
2068                Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2069                Warn_On_Known_Condition (N);
2070                return;
2071             end if;
2072          end;
2073       end if;
2074
2075       --  Can only fold if type is scalar (don't fold string ops)
2076
2077       if not Is_Scalar_Type (Typ) then
2078          Check_Non_Static_Context (Left);
2079          Check_Non_Static_Context (Right);
2080          return;
2081       end if;
2082
2083       --  If not foldable we are done
2084
2085       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2086
2087       if not Fold then
2088          return;
2089       end if;
2090
2091       --  Integer and Enumeration (discrete) type cases
2092
2093       if Is_Discrete_Type (Typ) then
2094          declare
2095             Left_Int  : constant Uint := Expr_Value (Left);
2096             Right_Int : constant Uint := Expr_Value (Right);
2097
2098          begin
2099             case Nkind (N) is
2100                when N_Op_Eq => Result := Left_Int =  Right_Int;
2101                when N_Op_Ne => Result := Left_Int /= Right_Int;
2102                when N_Op_Lt => Result := Left_Int <  Right_Int;
2103                when N_Op_Le => Result := Left_Int <= Right_Int;
2104                when N_Op_Gt => Result := Left_Int >  Right_Int;
2105                when N_Op_Ge => Result := Left_Int >= Right_Int;
2106
2107                when others =>
2108                   raise Program_Error;
2109             end case;
2110
2111             Fold_Uint (N, Test (Result), Stat);
2112          end;
2113
2114       --  Real type case
2115
2116       else
2117          pragma Assert (Is_Real_Type (Typ));
2118
2119          declare
2120             Left_Real  : constant Ureal := Expr_Value_R (Left);
2121             Right_Real : constant Ureal := Expr_Value_R (Right);
2122
2123          begin
2124             case Nkind (N) is
2125                when N_Op_Eq => Result := (Left_Real =  Right_Real);
2126                when N_Op_Ne => Result := (Left_Real /= Right_Real);
2127                when N_Op_Lt => Result := (Left_Real <  Right_Real);
2128                when N_Op_Le => Result := (Left_Real <= Right_Real);
2129                when N_Op_Gt => Result := (Left_Real >  Right_Real);
2130                when N_Op_Ge => Result := (Left_Real >= Right_Real);
2131
2132                when others =>
2133                   raise Program_Error;
2134             end case;
2135
2136             Fold_Uint (N, Test (Result), Stat);
2137          end;
2138       end if;
2139
2140       Warn_On_Known_Condition (N);
2141    end Eval_Relational_Op;
2142
2143    ----------------
2144    -- Eval_Shift --
2145    ----------------
2146
2147    --  Shift operations are intrinsic operations that can never be static,
2148    --  so the only processing required is to perform the required check for
2149    --  a non static context for the two operands.
2150
2151    --  Actually we could do some compile time evaluation here some time ???
2152
2153    procedure Eval_Shift (N : Node_Id) is
2154    begin
2155       Check_Non_Static_Context (Left_Opnd (N));
2156       Check_Non_Static_Context (Right_Opnd (N));
2157    end Eval_Shift;
2158
2159    ------------------------
2160    -- Eval_Short_Circuit --
2161    ------------------------
2162
2163    --  A short circuit operation is potentially static if both operands
2164    --  are potentially static (RM 4.9 (13))
2165
2166    procedure Eval_Short_Circuit (N : Node_Id) is
2167       Kind     : constant Node_Kind := Nkind (N);
2168       Left     : constant Node_Id   := Left_Opnd (N);
2169       Right    : constant Node_Id   := Right_Opnd (N);
2170       Left_Int : Uint;
2171       Rstat    : constant Boolean   :=
2172                    Is_Static_Expression (Left)
2173                      and then Is_Static_Expression (Right);
2174
2175    begin
2176       --  Short circuit operations are never static in Ada 83
2177
2178       if Ada_83
2179         and then Comes_From_Source (N)
2180       then
2181          Check_Non_Static_Context (Left);
2182          Check_Non_Static_Context (Right);
2183          return;
2184       end if;
2185
2186       --  Now look at the operands, we can't quite use the normal call to
2187       --  Test_Expression_Is_Foldable here because short circuit operations
2188       --  are a special case, they can still be foldable, even if the right
2189       --  operand raises constraint error.
2190
2191       --  If either operand is Any_Type, just propagate to result and
2192       --  do not try to fold, this prevents cascaded errors.
2193
2194       if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2195          Set_Etype (N, Any_Type);
2196          return;
2197
2198       --  If left operand raises constraint error, then replace node N with
2199       --  the raise constraint error node, and we are obviously not foldable.
2200       --  Is_Static_Expression is set from the two operands in the normal way,
2201       --  and we check the right operand if it is in a non-static context.
2202
2203       elsif Raises_Constraint_Error (Left) then
2204          if not Rstat then
2205             Check_Non_Static_Context (Right);
2206          end if;
2207
2208          Rewrite_In_Raise_CE (N, Left);
2209          Set_Is_Static_Expression (N, Rstat);
2210          return;
2211
2212       --  If the result is not static, then we won't in any case fold
2213
2214       elsif not Rstat then
2215          Check_Non_Static_Context (Left);
2216          Check_Non_Static_Context (Right);
2217          return;
2218       end if;
2219
2220       --  Here the result is static, note that, unlike the normal processing
2221       --  in Test_Expression_Is_Foldable, we did *not* check above to see if
2222       --  the right operand raises constraint error, that's because it is not
2223       --  significant if the left operand is decisive.
2224
2225       Set_Is_Static_Expression (N);
2226
2227       --  It does not matter if the right operand raises constraint error if
2228       --  it will not be evaluated. So deal specially with the cases where
2229       --  the right operand is not evaluated. Note that we will fold these
2230       --  cases even if the right operand is non-static, which is fine, but
2231       --  of course in these cases the result is not potentially static.
2232
2233       Left_Int := Expr_Value (Left);
2234
2235       if (Kind = N_And_Then and then Is_False (Left_Int))
2236         or else (Kind = N_Or_Else and Is_True (Left_Int))
2237       then
2238          Fold_Uint (N, Left_Int, Rstat);
2239          return;
2240       end if;
2241
2242       --  If first operand not decisive, then it does matter if the right
2243       --  operand raises constraint error, since it will be evaluated, so
2244       --  we simply replace the node with the right operand. Note that this
2245       --  properly propagates Is_Static_Expression and Raises_Constraint_Error
2246       --  (both are set to True in Right).
2247
2248       if Raises_Constraint_Error (Right) then
2249          Rewrite_In_Raise_CE (N, Right);
2250          Check_Non_Static_Context (Left);
2251          return;
2252       end if;
2253
2254       --  Otherwise the result depends on the right operand
2255
2256       Fold_Uint (N, Expr_Value (Right), Rstat);
2257       return;
2258    end Eval_Short_Circuit;
2259
2260    ----------------
2261    -- Eval_Slice --
2262    ----------------
2263
2264    --  Slices can never be static, so the only processing required is to
2265    --  check for non-static context if an explicit range is given.
2266
2267    procedure Eval_Slice (N : Node_Id) is
2268       Drange : constant Node_Id := Discrete_Range (N);
2269
2270    begin
2271       if Nkind (Drange) = N_Range then
2272          Check_Non_Static_Context (Low_Bound (Drange));
2273          Check_Non_Static_Context (High_Bound (Drange));
2274       end if;
2275    end Eval_Slice;
2276
2277    -------------------------
2278    -- Eval_String_Literal --
2279    -------------------------
2280
2281    procedure Eval_String_Literal (N : Node_Id) is
2282       T : constant Entity_Id := Etype (N);
2283       B : constant Entity_Id := Base_Type (T);
2284       I : Entity_Id;
2285
2286    begin
2287       --  Nothing to do if error type (handles cases like default expressions
2288       --  or generics where we have not yet fully resolved the type)
2289
2290       if B = Any_Type or else B = Any_String then
2291          return;
2292
2293       --  String literals are static if the subtype is static (RM 4.9(2)), so
2294       --  reset the static expression flag (it was set unconditionally in
2295       --  Analyze_String_Literal) if the subtype is non-static. We tell if
2296       --  the subtype is static by looking at the lower bound.
2297
2298       elsif not Is_OK_Static_Expression (String_Literal_Low_Bound (T)) then
2299          Set_Is_Static_Expression (N, False);
2300
2301       elsif Nkind (Original_Node (N)) = N_Type_Conversion then
2302          Set_Is_Static_Expression (N, False);
2303
2304       --  Test for illegal Ada 95 cases. A string literal is illegal in
2305       --  Ada 95 if its bounds are outside the index base type and this
2306       --  index type is static. This can hapen in only two ways. Either
2307       --  the string literal is too long, or it is null, and the lower
2308       --  bound is type'First. In either case it is the upper bound that
2309       --  is out of range of the index type.
2310
2311       elsif Ada_95 then
2312          if Root_Type (B) = Standard_String
2313            or else Root_Type (B) = Standard_Wide_String
2314          then
2315             I := Standard_Positive;
2316          else
2317             I := Etype (First_Index (B));
2318          end if;
2319
2320          if String_Literal_Length (T) > String_Type_Len (B) then
2321             Apply_Compile_Time_Constraint_Error
2322               (N, "string literal too long for}", CE_Length_Check_Failed,
2323                Ent => B,
2324                Typ => First_Subtype (B));
2325
2326          elsif String_Literal_Length (T) = 0
2327             and then not Is_Generic_Type (I)
2328             and then Expr_Value (String_Literal_Low_Bound (T)) =
2329                      Expr_Value (Type_Low_Bound (Base_Type (I)))
2330          then
2331             Apply_Compile_Time_Constraint_Error
2332               (N, "null string literal not allowed for}",
2333                CE_Length_Check_Failed,
2334                Ent => B,
2335                Typ => First_Subtype (B));
2336          end if;
2337       end if;
2338
2339    end Eval_String_Literal;
2340
2341    --------------------------
2342    -- Eval_Type_Conversion --
2343    --------------------------
2344
2345    --  A type conversion is potentially static if its subtype mark is for a
2346    --  static scalar subtype, and its operand expression is potentially static
2347    --  (RM 4.9 (10))
2348
2349    procedure Eval_Type_Conversion (N : Node_Id) is
2350       Operand     : constant Node_Id   := Expression (N);
2351       Source_Type : constant Entity_Id := Etype (Operand);
2352       Target_Type : constant Entity_Id := Etype (N);
2353
2354       Stat   : Boolean;
2355       Fold   : Boolean;
2356
2357       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
2358       --  Returns true if type T is an integer type, or if it is a
2359       --  fixed-point type to be treated as an integer (i.e. the flag
2360       --  Conversion_OK is set on the conversion node).
2361
2362       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
2363       --  Returns true if type T is a floating-point type, or if it is a
2364       --  fixed-point type that is not to be treated as an integer (i.e. the
2365       --  flag Conversion_OK is not set on the conversion node).
2366
2367       ------------------------------
2368       -- To_Be_Treated_As_Integer --
2369       ------------------------------
2370
2371       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
2372       begin
2373          return
2374            Is_Integer_Type (T)
2375              or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
2376       end To_Be_Treated_As_Integer;
2377
2378       ---------------------------
2379       -- To_Be_Treated_As_Real --
2380       ---------------------------
2381
2382       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
2383       begin
2384          return
2385            Is_Floating_Point_Type (T)
2386              or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
2387       end To_Be_Treated_As_Real;
2388
2389    --  Start of processing for Eval_Type_Conversion
2390
2391    begin
2392       --  Cannot fold if target type is non-static or if semantic error.
2393
2394       if not Is_Static_Subtype (Target_Type) then
2395          Check_Non_Static_Context (Operand);
2396          return;
2397
2398       elsif Error_Posted (N) then
2399          return;
2400       end if;
2401
2402       --  If not foldable we are done
2403
2404       Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2405
2406       if not Fold then
2407          return;
2408
2409       --  Don't try fold if target type has constraint error bounds
2410
2411       elsif not Is_OK_Static_Subtype (Target_Type) then
2412          Set_Raises_Constraint_Error (N);
2413          return;
2414       end if;
2415
2416       --  Remaining processing depends on operand types. Note that in the
2417       --  following type test, fixed-point counts as real unless the flag
2418       --  Conversion_OK is set, in which case it counts as integer.
2419
2420       --  Fold conversion, case of string type. The result is not static.
2421
2422       if Is_String_Type (Target_Type) then
2423          Fold_Str (N, Strval (Get_String_Val (Operand)), False);
2424
2425          return;
2426
2427       --  Fold conversion, case of integer target type
2428
2429       elsif To_Be_Treated_As_Integer (Target_Type) then
2430          declare
2431             Result : Uint;
2432
2433          begin
2434             --  Integer to integer conversion
2435
2436             if To_Be_Treated_As_Integer (Source_Type) then
2437                Result := Expr_Value (Operand);
2438
2439             --  Real to integer conversion
2440
2441             else
2442                Result := UR_To_Uint (Expr_Value_R (Operand));
2443             end if;
2444
2445             --  If fixed-point type (Conversion_OK must be set), then the
2446             --  result is logically an integer, but we must replace the
2447             --  conversion with the corresponding real literal, since the
2448             --  type from a semantic point of view is still fixed-point.
2449
2450             if Is_Fixed_Point_Type (Target_Type) then
2451                Fold_Ureal
2452                  (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
2453
2454             --  Otherwise result is integer literal
2455
2456             else
2457                Fold_Uint (N, Result, Stat);
2458             end if;
2459          end;
2460
2461       --  Fold conversion, case of real target type
2462
2463       elsif To_Be_Treated_As_Real (Target_Type) then
2464          declare
2465             Result : Ureal;
2466
2467          begin
2468             if To_Be_Treated_As_Real (Source_Type) then
2469                Result := Expr_Value_R (Operand);
2470             else
2471                Result := UR_From_Uint (Expr_Value (Operand));
2472             end if;
2473
2474             Fold_Ureal (N, Result, Stat);
2475          end;
2476
2477       --  Enumeration types
2478
2479       else
2480          Fold_Uint (N, Expr_Value (Operand), Stat);
2481       end if;
2482
2483       if Is_Out_Of_Range (N, Etype (N)) then
2484          Out_Of_Range (N);
2485       end if;
2486
2487    end Eval_Type_Conversion;
2488
2489    -------------------
2490    -- Eval_Unary_Op --
2491    -------------------
2492
2493    --  Predefined unary operators are static functions (RM 4.9(20)) and thus
2494    --  are potentially static if the operand is potentially static (RM 4.9(7))
2495
2496    procedure Eval_Unary_Op (N : Node_Id) is
2497       Right : constant Node_Id := Right_Opnd (N);
2498       Stat  : Boolean;
2499       Fold  : Boolean;
2500
2501    begin
2502       --  If not foldable we are done
2503
2504       Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2505
2506       if not Fold then
2507          return;
2508       end if;
2509
2510       --  Fold for integer case
2511
2512       if Is_Integer_Type (Etype (N)) then
2513          declare
2514             Rint   : constant Uint := Expr_Value (Right);
2515             Result : Uint;
2516
2517          begin
2518             --  In the case of modular unary plus and abs there is no need
2519             --  to adjust the result of the operation since if the original
2520             --  operand was in bounds the result will be in the bounds of the
2521             --  modular type. However, in the case of modular unary minus the
2522             --  result may go out of the bounds of the modular type and needs
2523             --  adjustment.
2524
2525             if Nkind (N) = N_Op_Plus then
2526                Result := Rint;
2527
2528             elsif Nkind (N) = N_Op_Minus then
2529                if Is_Modular_Integer_Type (Etype (N)) then
2530                   Result := (-Rint) mod Modulus (Etype (N));
2531                else
2532                   Result := (-Rint);
2533                end if;
2534
2535             else
2536                pragma Assert (Nkind (N) = N_Op_Abs);
2537                Result := abs Rint;
2538             end if;
2539
2540             Fold_Uint (N, Result, Stat);
2541          end;
2542
2543       --  Fold for real case
2544
2545       elsif Is_Real_Type (Etype (N)) then
2546          declare
2547             Rreal  : constant Ureal := Expr_Value_R (Right);
2548             Result : Ureal;
2549
2550          begin
2551             if Nkind (N) = N_Op_Plus then
2552                Result := Rreal;
2553
2554             elsif Nkind (N) = N_Op_Minus then
2555                Result := UR_Negate (Rreal);
2556
2557             else
2558                pragma Assert (Nkind (N) = N_Op_Abs);
2559                Result := abs Rreal;
2560             end if;
2561
2562             Fold_Ureal (N, Result, Stat);
2563          end;
2564       end if;
2565    end Eval_Unary_Op;
2566
2567    -------------------------------
2568    -- Eval_Unchecked_Conversion --
2569    -------------------------------
2570
2571    --  Unchecked conversions can never be static, so the only required
2572    --  processing is to check for a non-static context for the operand.
2573
2574    procedure Eval_Unchecked_Conversion (N : Node_Id) is
2575    begin
2576       Check_Non_Static_Context (Expression (N));
2577    end Eval_Unchecked_Conversion;
2578
2579    --------------------
2580    -- Expr_Rep_Value --
2581    --------------------
2582
2583    function Expr_Rep_Value (N : Node_Id) return Uint is
2584       Kind : constant Node_Kind := Nkind (N);
2585       Ent  : Entity_Id;
2586
2587    begin
2588       if Is_Entity_Name (N) then
2589          Ent := Entity (N);
2590
2591          --  An enumeration literal that was either in the source or
2592          --  created as a result of static evaluation.
2593
2594          if Ekind (Ent) = E_Enumeration_Literal then
2595             return Enumeration_Rep (Ent);
2596
2597          --  A user defined static constant
2598
2599          else
2600             pragma Assert (Ekind (Ent) = E_Constant);
2601             return Expr_Rep_Value (Constant_Value (Ent));
2602          end if;
2603
2604       --  An integer literal that was either in the source or created
2605       --  as a result of static evaluation.
2606
2607       elsif Kind = N_Integer_Literal then
2608          return Intval (N);
2609
2610       --  A real literal for a fixed-point type. This must be the fixed-point
2611       --  case, either the literal is of a fixed-point type, or it is a bound
2612       --  of a fixed-point type, with type universal real. In either case we
2613       --  obtain the desired value from Corresponding_Integer_Value.
2614
2615       elsif Kind = N_Real_Literal then
2616          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
2617          return Corresponding_Integer_Value (N);
2618
2619       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
2620
2621       elsif Kind = N_Attribute_Reference
2622         and then Attribute_Name (N) = Name_Null_Parameter
2623       then
2624          return Uint_0;
2625
2626       --  Otherwise must be character literal
2627
2628       else
2629          pragma Assert (Kind = N_Character_Literal);
2630          Ent := Entity (N);
2631
2632          --  Since Character literals of type Standard.Character don't
2633          --  have any defining character literals built for them, they
2634          --  do not have their Entity set, so just use their Char
2635          --  code. Otherwise for user-defined character literals use
2636          --  their Pos value as usual which is the same as the Rep value.
2637
2638          if No (Ent) then
2639             return UI_From_Int (Int (Char_Literal_Value (N)));
2640          else
2641             return Enumeration_Rep (Ent);
2642          end if;
2643       end if;
2644    end Expr_Rep_Value;
2645
2646    ----------------
2647    -- Expr_Value --
2648    ----------------
2649
2650    function Expr_Value (N : Node_Id) return Uint is
2651       Kind   : constant Node_Kind := Nkind (N);
2652       CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
2653       Ent    : Entity_Id;
2654       Val    : Uint;
2655
2656    begin
2657       --  If already in cache, then we know it's compile time known and
2658       --  we can return the value that was previously stored in the cache
2659       --  since compile time known values cannot change :-)
2660
2661       if CV_Ent.N = N then
2662          return CV_Ent.V;
2663       end if;
2664
2665       --  Otherwise proceed to test value
2666
2667       if Is_Entity_Name (N) then
2668          Ent := Entity (N);
2669
2670          --  An enumeration literal that was either in the source or
2671          --  created as a result of static evaluation.
2672
2673          if Ekind (Ent) = E_Enumeration_Literal then
2674             Val := Enumeration_Pos (Ent);
2675
2676          --  A user defined static constant
2677
2678          else
2679             pragma Assert (Ekind (Ent) = E_Constant);
2680             Val := Expr_Value (Constant_Value (Ent));
2681          end if;
2682
2683       --  An integer literal that was either in the source or created
2684       --  as a result of static evaluation.
2685
2686       elsif Kind = N_Integer_Literal then
2687          Val := Intval (N);
2688
2689       --  A real literal for a fixed-point type. This must be the fixed-point
2690       --  case, either the literal is of a fixed-point type, or it is a bound
2691       --  of a fixed-point type, with type universal real. In either case we
2692       --  obtain the desired value from Corresponding_Integer_Value.
2693
2694       elsif Kind = N_Real_Literal then
2695
2696          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
2697          Val := Corresponding_Integer_Value (N);
2698
2699       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
2700
2701       elsif Kind = N_Attribute_Reference
2702         and then Attribute_Name (N) = Name_Null_Parameter
2703       then
2704          Val := Uint_0;
2705
2706       --  Otherwise must be character literal
2707
2708       else
2709          pragma Assert (Kind = N_Character_Literal);
2710          Ent := Entity (N);
2711
2712          --  Since Character literals of type Standard.Character don't
2713          --  have any defining character literals built for them, they
2714          --  do not have their Entity set, so just use their Char
2715          --  code. Otherwise for user-defined character literals use
2716          --  their Pos value as usual.
2717
2718          if No (Ent) then
2719             Val := UI_From_Int (Int (Char_Literal_Value (N)));
2720          else
2721             Val := Enumeration_Pos (Ent);
2722          end if;
2723       end if;
2724
2725       --  Come here with Val set to value to be returned, set cache
2726
2727       CV_Ent.N := N;
2728       CV_Ent.V := Val;
2729       return Val;
2730    end Expr_Value;
2731
2732    ------------------
2733    -- Expr_Value_E --
2734    ------------------
2735
2736    function Expr_Value_E (N : Node_Id) return Entity_Id is
2737       Ent  : constant Entity_Id := Entity (N);
2738
2739    begin
2740       if Ekind (Ent) = E_Enumeration_Literal then
2741          return Ent;
2742       else
2743          pragma Assert (Ekind (Ent) = E_Constant);
2744          return Expr_Value_E (Constant_Value (Ent));
2745       end if;
2746    end Expr_Value_E;
2747
2748    ------------------
2749    -- Expr_Value_R --
2750    ------------------
2751
2752    function Expr_Value_R (N : Node_Id) return Ureal is
2753       Kind : constant Node_Kind := Nkind (N);
2754       Ent  : Entity_Id;
2755       Expr : Node_Id;
2756
2757    begin
2758       if Kind = N_Real_Literal then
2759          return Realval (N);
2760
2761       elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
2762          Ent := Entity (N);
2763          pragma Assert (Ekind (Ent) = E_Constant);
2764          return Expr_Value_R (Constant_Value (Ent));
2765
2766       elsif Kind = N_Integer_Literal then
2767          return UR_From_Uint (Expr_Value (N));
2768
2769       --  Strange case of VAX literals, which are at this stage transformed
2770       --  into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
2771       --  Exp_Vfpt for further details.
2772
2773       elsif Vax_Float (Etype (N))
2774         and then Nkind (N) = N_Unchecked_Type_Conversion
2775       then
2776          Expr := Expression (N);
2777
2778          if Nkind (Expr) = N_Function_Call
2779            and then Present (Parameter_Associations (Expr))
2780          then
2781             Expr := First (Parameter_Associations (Expr));
2782
2783             if Nkind (Expr) = N_Real_Literal then
2784                return Realval (Expr);
2785             end if;
2786          end if;
2787
2788       --  Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
2789
2790       elsif Kind = N_Attribute_Reference
2791         and then Attribute_Name (N) = Name_Null_Parameter
2792       then
2793          return Ureal_0;
2794       end if;
2795
2796       --  If we fall through, we have a node that cannot be interepreted
2797       --  as a compile time constant. That is definitely an error.
2798
2799       raise Program_Error;
2800    end Expr_Value_R;
2801
2802    ------------------
2803    -- Expr_Value_S --
2804    ------------------
2805
2806    function Expr_Value_S (N : Node_Id) return Node_Id is
2807    begin
2808       if Nkind (N) = N_String_Literal then
2809          return N;
2810       else
2811          pragma Assert (Ekind (Entity (N)) = E_Constant);
2812          return Expr_Value_S (Constant_Value (Entity (N)));
2813       end if;
2814    end Expr_Value_S;
2815
2816    --------------------------
2817    -- Flag_Non_Static_Expr --
2818    --------------------------
2819
2820    procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
2821    begin
2822       if Error_Posted (Expr) and then not All_Errors_Mode then
2823          return;
2824       else
2825          Error_Msg_F (Msg, Expr);
2826          Why_Not_Static (Expr);
2827       end if;
2828    end Flag_Non_Static_Expr;
2829
2830    --------------
2831    -- Fold_Str --
2832    --------------
2833
2834    procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
2835       Loc : constant Source_Ptr := Sloc (N);
2836       Typ : constant Entity_Id  := Etype (N);
2837
2838    begin
2839       Rewrite (N, Make_String_Literal (Loc, Strval => Val));
2840
2841       --  We now have the literal with the right value, both the actual type
2842       --  and the expected type of this literal are taken from the expression
2843       --  that was evaluated.
2844
2845       Analyze (N);
2846       Set_Is_Static_Expression (N, Static);
2847       Set_Etype (N, Typ);
2848       Resolve (N);
2849    end Fold_Str;
2850
2851    ---------------
2852    -- Fold_Uint --
2853    ---------------
2854
2855    procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
2856       Loc : constant Source_Ptr := Sloc (N);
2857       Typ : Entity_Id  := Etype (N);
2858       Ent : Entity_Id;
2859
2860    begin
2861       --  If we are folding a named number, retain the entity in the
2862       --  literal, for ASIS use.
2863
2864       if Is_Entity_Name (N)
2865         and then Ekind (Entity (N)) = E_Named_Integer
2866       then
2867          Ent := Entity (N);
2868       else
2869          Ent := Empty;
2870       end if;
2871
2872       if Is_Private_Type (Typ) then
2873          Typ := Full_View (Typ);
2874       end if;
2875
2876       --  For a result of type integer, subsitute an N_Integer_Literal node
2877       --  for the result of the compile time evaluation of the expression.
2878
2879       if Is_Integer_Type (Typ) then
2880          Rewrite (N, Make_Integer_Literal (Loc, Val));
2881          Set_Original_Entity (N, Ent);
2882
2883       --  Otherwise we have an enumeration type, and we substitute either
2884       --  an N_Identifier or N_Character_Literal to represent the enumeration
2885       --  literal corresponding to the given value, which must always be in
2886       --  range, because appropriate tests have already been made for this.
2887
2888       else pragma Assert (Is_Enumeration_Type (Typ));
2889          Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
2890       end if;
2891
2892       --  We now have the literal with the right value, both the actual type
2893       --  and the expected type of this literal are taken from the expression
2894       --  that was evaluated.
2895
2896       Analyze (N);
2897       Set_Is_Static_Expression (N, Static);
2898       Set_Etype (N, Typ);
2899       Resolve (N);
2900    end Fold_Uint;
2901
2902    ----------------
2903    -- Fold_Ureal --
2904    ----------------
2905
2906    procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
2907       Loc : constant Source_Ptr := Sloc (N);
2908       Typ : constant Entity_Id  := Etype (N);
2909       Ent : Entity_Id;
2910
2911    begin
2912       --  If we are folding a named number, retain the entity in the
2913       --  literal, for ASIS use.
2914
2915       if Is_Entity_Name (N)
2916         and then Ekind (Entity (N)) = E_Named_Real
2917       then
2918          Ent := Entity (N);
2919       else
2920          Ent := Empty;
2921       end if;
2922
2923       Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
2924       Set_Original_Entity (N, Ent);
2925
2926       --  Both the actual and expected type comes from the original expression
2927
2928       Analyze (N);
2929       Set_Is_Static_Expression (N, Static);
2930       Set_Etype (N, Typ);
2931       Resolve (N);
2932    end Fold_Ureal;
2933
2934    ---------------
2935    -- From_Bits --
2936    ---------------
2937
2938    function From_Bits (B : Bits; T : Entity_Id) return Uint is
2939       V : Uint := Uint_0;
2940
2941    begin
2942       for J in 0 .. B'Last loop
2943          if B (J) then
2944             V := V + 2 ** J;
2945          end if;
2946       end loop;
2947
2948       if Non_Binary_Modulus (T) then
2949          V := V mod Modulus (T);
2950       end if;
2951
2952       return V;
2953    end From_Bits;
2954
2955    --------------------
2956    -- Get_String_Val --
2957    --------------------
2958
2959    function Get_String_Val (N : Node_Id) return Node_Id is
2960    begin
2961       if Nkind (N) = N_String_Literal then
2962          return N;
2963
2964       elsif Nkind (N) = N_Character_Literal then
2965          return N;
2966
2967       else
2968          pragma Assert (Is_Entity_Name (N));
2969          return Get_String_Val (Constant_Value (Entity (N)));
2970       end if;
2971    end Get_String_Val;
2972
2973    ----------------
2974    -- Initialize --
2975    ----------------
2976
2977    procedure Initialize is
2978    begin
2979       CV_Cache := (others => (Node_High_Bound, Uint_0));
2980    end Initialize;
2981
2982    --------------------
2983    -- In_Subrange_Of --
2984    --------------------
2985
2986    function In_Subrange_Of
2987      (T1        : Entity_Id;
2988       T2        : Entity_Id;
2989       Fixed_Int : Boolean := False)
2990       return      Boolean
2991    is
2992       L1 : Node_Id;
2993       H1 : Node_Id;
2994
2995       L2 : Node_Id;
2996       H2 : Node_Id;
2997
2998    begin
2999       if T1 = T2 or else Is_Subtype_Of (T1, T2) then
3000          return True;
3001
3002       --  Never in range if both types are not scalar. Don't know if this can
3003       --  actually happen, but just in case.
3004
3005       elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
3006          return False;
3007
3008       else
3009          L1 := Type_Low_Bound  (T1);
3010          H1 := Type_High_Bound (T1);
3011
3012          L2 := Type_Low_Bound  (T2);
3013          H2 := Type_High_Bound (T2);
3014
3015          --  Check bounds to see if comparison possible at compile time
3016
3017          if Compile_Time_Compare (L1, L2) in Compare_GE
3018               and then
3019             Compile_Time_Compare (H1, H2) in Compare_LE
3020          then
3021             return True;
3022          end if;
3023
3024          --  If bounds not comparable at compile time, then the bounds of T2
3025          --  must be compile time known or we cannot answer the query.
3026
3027          if not Compile_Time_Known_Value (L2)
3028            or else not Compile_Time_Known_Value (H2)
3029          then
3030             return False;
3031          end if;
3032
3033          --  If the bounds of T1 are know at compile time then use these
3034          --  ones, otherwise use the bounds of the base type (which are of
3035          --  course always static).
3036
3037          if not Compile_Time_Known_Value (L1) then
3038             L1 := Type_Low_Bound (Base_Type (T1));
3039          end if;
3040
3041          if not Compile_Time_Known_Value (H1) then
3042             H1 := Type_High_Bound (Base_Type (T1));
3043          end if;
3044
3045          --  Fixed point types should be considered as such only if
3046          --  flag Fixed_Int is set to False.
3047
3048          if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
3049            or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
3050            or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
3051          then
3052             return
3053               Expr_Value_R (L2) <= Expr_Value_R (L1)
3054                 and then
3055               Expr_Value_R (H2) >= Expr_Value_R (H1);
3056
3057          else
3058             return
3059               Expr_Value (L2) <= Expr_Value (L1)
3060                 and then
3061               Expr_Value (H2) >= Expr_Value (H1);
3062
3063          end if;
3064       end if;
3065
3066    --  If any exception occurs, it means that we have some bug in the compiler
3067    --  possibly triggered by a previous error, or by some unforseen peculiar
3068    --  occurrence. However, this is only an optimization attempt, so there is
3069    --  really no point in crashing the compiler. Instead we just decide, too
3070    --  bad, we can't figure out the answer in this case after all.
3071
3072    exception
3073       when others =>
3074
3075          --  Debug flag K disables this behavior (useful for debugging)
3076
3077          if Debug_Flag_K then
3078             raise;
3079          else
3080             return False;
3081          end if;
3082    end In_Subrange_Of;
3083
3084    -----------------
3085    -- Is_In_Range --
3086    -----------------
3087
3088    function Is_In_Range
3089      (N         : Node_Id;
3090       Typ       : Entity_Id;
3091       Fixed_Int : Boolean := False;
3092       Int_Real  : Boolean := False)
3093       return      Boolean
3094    is
3095       Val  : Uint;
3096       Valr : Ureal;
3097
3098    begin
3099       --  Universal types have no range limits, so always in range.
3100
3101       if Typ = Universal_Integer or else Typ = Universal_Real then
3102          return True;
3103
3104       --  Never in range if not scalar type. Don't know if this can
3105       --  actually happen, but our spec allows it, so we must check!
3106
3107       elsif not Is_Scalar_Type (Typ) then
3108          return False;
3109
3110       --  Never in range unless we have a compile time known value.
3111
3112       elsif not Compile_Time_Known_Value (N) then
3113          return False;
3114
3115       else
3116          declare
3117             Lo       : constant Node_Id := Type_Low_Bound  (Typ);
3118             Hi       : constant Node_Id := Type_High_Bound (Typ);
3119             LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
3120             UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
3121
3122          begin
3123             --  Fixed point types should be considered as such only in
3124             --  flag Fixed_Int is set to False.
3125
3126             if Is_Floating_Point_Type (Typ)
3127               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3128               or else Int_Real
3129             then
3130                Valr := Expr_Value_R (N);
3131
3132                if LB_Known and then Valr >= Expr_Value_R (Lo)
3133                  and then UB_Known and then Valr <= Expr_Value_R (Hi)
3134                then
3135                   return True;
3136                else
3137                   return False;
3138                end if;
3139
3140             else
3141                Val := Expr_Value (N);
3142
3143                if         LB_Known and then Val >= Expr_Value (Lo)
3144                  and then UB_Known and then Val <= Expr_Value (Hi)
3145                then
3146                   return True;
3147                else
3148                   return False;
3149                end if;
3150             end if;
3151          end;
3152       end if;
3153    end Is_In_Range;
3154
3155    -------------------
3156    -- Is_Null_Range --
3157    -------------------
3158
3159    function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3160       Typ : constant Entity_Id := Etype (Lo);
3161
3162    begin
3163       if not Compile_Time_Known_Value (Lo)
3164         or else not Compile_Time_Known_Value (Hi)
3165       then
3166          return False;
3167       end if;
3168
3169       if Is_Discrete_Type (Typ) then
3170          return Expr_Value (Lo) > Expr_Value (Hi);
3171
3172       else
3173          pragma Assert (Is_Real_Type (Typ));
3174          return Expr_Value_R (Lo) > Expr_Value_R (Hi);
3175       end if;
3176    end Is_Null_Range;
3177
3178    -----------------------------
3179    -- Is_OK_Static_Expression --
3180    -----------------------------
3181
3182    function Is_OK_Static_Expression (N : Node_Id) return Boolean is
3183    begin
3184       return Is_Static_Expression (N)
3185         and then not Raises_Constraint_Error (N);
3186    end Is_OK_Static_Expression;
3187
3188    ------------------------
3189    -- Is_OK_Static_Range --
3190    ------------------------
3191
3192    --  A static range is a range whose bounds are static expressions, or a
3193    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3194    --  We have already converted range attribute references, so we get the
3195    --  "or" part of this rule without needing a special test.
3196
3197    function Is_OK_Static_Range (N : Node_Id) return Boolean is
3198    begin
3199       return Is_OK_Static_Expression (Low_Bound (N))
3200         and then Is_OK_Static_Expression (High_Bound (N));
3201    end Is_OK_Static_Range;
3202
3203    --------------------------
3204    -- Is_OK_Static_Subtype --
3205    --------------------------
3206
3207    --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
3208    --  where neither bound raises constraint error when evaluated.
3209
3210    function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
3211       Base_T   : constant Entity_Id := Base_Type (Typ);
3212       Anc_Subt : Entity_Id;
3213
3214    begin
3215       --  First a quick check on the non static subtype flag. As described
3216       --  in further detail in Einfo, this flag is not decisive in all cases,
3217       --  but if it is set, then the subtype is definitely non-static.
3218
3219       if Is_Non_Static_Subtype (Typ) then
3220          return False;
3221       end if;
3222
3223       Anc_Subt := Ancestor_Subtype (Typ);
3224
3225       if Anc_Subt = Empty then
3226          Anc_Subt := Base_T;
3227       end if;
3228
3229       if Is_Generic_Type (Root_Type (Base_T))
3230         or else Is_Generic_Actual_Type (Base_T)
3231       then
3232          return False;
3233
3234       --  String types
3235
3236       elsif Is_String_Type (Typ) then
3237          return
3238            Ekind (Typ) = E_String_Literal_Subtype
3239              or else
3240            (Is_OK_Static_Subtype (Component_Type (Typ))
3241               and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
3242
3243       --  Scalar types
3244
3245       elsif Is_Scalar_Type (Typ) then
3246          if Base_T = Typ then
3247             return True;
3248
3249          else
3250             --  Scalar_Range (Typ) might be an N_Subtype_Indication, so
3251             --  use Get_Type_Low,High_Bound.
3252
3253             return     Is_OK_Static_Subtype (Anc_Subt)
3254               and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
3255               and then Is_OK_Static_Expression (Type_High_Bound (Typ));
3256          end if;
3257
3258       --  Types other than string and scalar types are never static
3259
3260       else
3261          return False;
3262       end if;
3263    end Is_OK_Static_Subtype;
3264
3265    ---------------------
3266    -- Is_Out_Of_Range --
3267    ---------------------
3268
3269    function Is_Out_Of_Range
3270      (N         : Node_Id;
3271       Typ       : Entity_Id;
3272       Fixed_Int : Boolean := False;
3273       Int_Real  : Boolean := False)
3274       return      Boolean
3275    is
3276       Val  : Uint;
3277       Valr : Ureal;
3278
3279    begin
3280       --  Universal types have no range limits, so always in range.
3281
3282       if Typ = Universal_Integer or else Typ = Universal_Real then
3283          return False;
3284
3285       --  Never out of range if not scalar type. Don't know if this can
3286       --  actually happen, but our spec allows it, so we must check!
3287
3288       elsif not Is_Scalar_Type (Typ) then
3289          return False;
3290
3291       --  Never out of range if this is a generic type, since the bounds
3292       --  of generic types are junk. Note that if we only checked for
3293       --  static expressions (instead of compile time known values) below,
3294       --  we would not need this check, because values of a generic type
3295       --  can never be static, but they can be known at compile time.
3296
3297       elsif Is_Generic_Type (Typ) then
3298          return False;
3299
3300       --  Never out of range unless we have a compile time known value
3301
3302       elsif not Compile_Time_Known_Value (N) then
3303          return False;
3304
3305       else
3306          declare
3307             Lo       : constant Node_Id := Type_Low_Bound  (Typ);
3308             Hi       : constant Node_Id := Type_High_Bound (Typ);
3309             LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
3310             UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
3311
3312          begin
3313             --  Real types (note that fixed-point types are not treated
3314             --  as being of a real type if the flag Fixed_Int is set,
3315             --  since in that case they are regarded as integer types).
3316
3317             if Is_Floating_Point_Type (Typ)
3318               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3319               or else Int_Real
3320             then
3321                Valr := Expr_Value_R (N);
3322
3323                if LB_Known and then Valr < Expr_Value_R (Lo) then
3324                   return True;
3325
3326                elsif UB_Known and then Expr_Value_R (Hi) < Valr then
3327                   return True;
3328
3329                else
3330                   return False;
3331                end if;
3332
3333             else
3334                Val := Expr_Value (N);
3335
3336                if LB_Known and then Val < Expr_Value (Lo) then
3337                   return True;
3338
3339                elsif UB_Known and then Expr_Value (Hi) < Val then
3340                   return True;
3341
3342                else
3343                   return False;
3344                end if;
3345             end if;
3346          end;
3347       end if;
3348    end Is_Out_Of_Range;
3349
3350    ---------------------
3351    -- Is_Static_Range --
3352    ---------------------
3353
3354    --  A static range is a range whose bounds are static expressions, or a
3355    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3356    --  We have already converted range attribute references, so we get the
3357    --  "or" part of this rule without needing a special test.
3358
3359    function Is_Static_Range (N : Node_Id) return Boolean is
3360    begin
3361       return Is_Static_Expression (Low_Bound (N))
3362         and then Is_Static_Expression (High_Bound (N));
3363    end Is_Static_Range;
3364
3365    -----------------------
3366    -- Is_Static_Subtype --
3367    -----------------------
3368
3369    --  Determines if Typ is a static subtype as defined in (RM 4.9(26)).
3370
3371    function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
3372       Base_T   : constant Entity_Id := Base_Type (Typ);
3373       Anc_Subt : Entity_Id;
3374
3375    begin
3376       --  First a quick check on the non static subtype flag. As described
3377       --  in further detail in Einfo, this flag is not decisive in all cases,
3378       --  but if it is set, then the subtype is definitely non-static.
3379
3380       if Is_Non_Static_Subtype (Typ) then
3381          return False;
3382       end if;
3383
3384       Anc_Subt := Ancestor_Subtype (Typ);
3385
3386       if Anc_Subt = Empty then
3387          Anc_Subt := Base_T;
3388       end if;
3389
3390       if Is_Generic_Type (Root_Type (Base_T))
3391         or else Is_Generic_Actual_Type (Base_T)
3392       then
3393          return False;
3394
3395       --  String types
3396
3397       elsif Is_String_Type (Typ) then
3398          return
3399            Ekind (Typ) = E_String_Literal_Subtype
3400              or else
3401            (Is_Static_Subtype (Component_Type (Typ))
3402               and then Is_Static_Subtype (Etype (First_Index (Typ))));
3403
3404       --  Scalar types
3405
3406       elsif Is_Scalar_Type (Typ) then
3407          if Base_T = Typ then
3408             return True;
3409
3410          else
3411             return     Is_Static_Subtype (Anc_Subt)
3412               and then Is_Static_Expression (Type_Low_Bound (Typ))
3413               and then Is_Static_Expression (Type_High_Bound (Typ));
3414          end if;
3415
3416       --  Types other than string and scalar types are never static
3417
3418       else
3419          return False;
3420       end if;
3421    end Is_Static_Subtype;
3422
3423    --------------------
3424    -- Not_Null_Range --
3425    --------------------
3426
3427    function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3428       Typ : constant Entity_Id := Etype (Lo);
3429
3430    begin
3431       if not Compile_Time_Known_Value (Lo)
3432         or else not Compile_Time_Known_Value (Hi)
3433       then
3434          return False;
3435       end if;
3436
3437       if Is_Discrete_Type (Typ) then
3438          return Expr_Value (Lo) <= Expr_Value (Hi);
3439
3440       else
3441          pragma Assert (Is_Real_Type (Typ));
3442
3443          return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
3444       end if;
3445    end Not_Null_Range;
3446
3447    -------------
3448    -- OK_Bits --
3449    -------------
3450
3451    function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
3452    begin
3453       --  We allow a maximum of 500,000 bits which seems a reasonable limit
3454
3455       if Bits < 500_000 then
3456          return True;
3457
3458       else
3459          Error_Msg_N ("static value too large, capacity exceeded", N);
3460          return False;
3461       end if;
3462    end OK_Bits;
3463
3464    ------------------
3465    -- Out_Of_Range --
3466    ------------------
3467
3468    procedure Out_Of_Range (N : Node_Id) is
3469    begin
3470       --  If we have the static expression case, then this is an illegality
3471       --  in Ada 95 mode, except that in an instance, we never generate an
3472       --  error (if the error is legitimate, it was already diagnosed in
3473       --  the template). The expression to compute the length of a packed
3474       --  array is attached to the array type itself, and deserves a separate
3475       --  message.
3476
3477       if Is_Static_Expression (N)
3478         and then not In_Instance
3479         and then not In_Inlined_Body
3480         and then Ada_95
3481       then
3482          if Nkind (Parent (N)) = N_Defining_Identifier
3483            and then Is_Array_Type (Parent (N))
3484            and then Present (Packed_Array_Type (Parent (N)))
3485            and then Present (First_Rep_Item (Parent (N)))
3486          then
3487             Error_Msg_N
3488              ("length of packed array must not exceed Integer''Last",
3489               First_Rep_Item (Parent (N)));
3490             Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
3491
3492          else
3493             Apply_Compile_Time_Constraint_Error
3494               (N, "value not in range of}", CE_Range_Check_Failed);
3495          end if;
3496
3497       --  Here we generate a warning for the Ada 83 case, or when we are
3498       --  in an instance, or when we have a non-static expression case.
3499
3500       else
3501          Apply_Compile_Time_Constraint_Error
3502            (N, "value not in range of}?", CE_Range_Check_Failed);
3503       end if;
3504    end Out_Of_Range;
3505
3506    -------------------------
3507    -- Rewrite_In_Raise_CE --
3508    -------------------------
3509
3510    procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
3511       Typ : constant Entity_Id := Etype (N);
3512
3513    begin
3514       --  If we want to raise CE in the condition of a raise_CE node
3515       --  we may as well get rid of the condition
3516
3517       if Present (Parent (N))
3518         and then Nkind (Parent (N)) = N_Raise_Constraint_Error
3519       then
3520          Set_Condition (Parent (N), Empty);
3521
3522       --  If the expression raising CE is a N_Raise_CE node, we can use
3523       --  that one. We just preserve the type of the context
3524
3525       elsif Nkind (Exp) = N_Raise_Constraint_Error then
3526          Rewrite (N, Exp);
3527          Set_Etype (N, Typ);
3528
3529       --  We have to build an explicit raise_ce node
3530
3531       else
3532          Rewrite (N,
3533            Make_Raise_Constraint_Error (Sloc (Exp),
3534              Reason => CE_Range_Check_Failed));
3535          Set_Raises_Constraint_Error (N);
3536          Set_Etype (N, Typ);
3537       end if;
3538    end Rewrite_In_Raise_CE;
3539
3540    ---------------------
3541    -- String_Type_Len --
3542    ---------------------
3543
3544    function String_Type_Len (Stype : Entity_Id) return Uint is
3545       NT : constant Entity_Id := Etype (First_Index (Stype));
3546       T  : Entity_Id;
3547
3548    begin
3549       if Is_OK_Static_Subtype (NT) then
3550          T := NT;
3551       else
3552          T := Base_Type (NT);
3553       end if;
3554
3555       return Expr_Value (Type_High_Bound (T)) -
3556              Expr_Value (Type_Low_Bound (T)) + 1;
3557    end String_Type_Len;
3558
3559    ------------------------------------
3560    -- Subtypes_Statically_Compatible --
3561    ------------------------------------
3562
3563    function Subtypes_Statically_Compatible
3564      (T1   : Entity_Id;
3565       T2   : Entity_Id)
3566       return Boolean
3567    is
3568    begin
3569       if Is_Scalar_Type (T1) then
3570
3571          --  Definitely compatible if we match
3572
3573          if Subtypes_Statically_Match (T1, T2) then
3574             return True;
3575
3576          --  If either subtype is nonstatic then they're not compatible
3577
3578          elsif not Is_Static_Subtype (T1)
3579            or else not Is_Static_Subtype (T2)
3580          then
3581             return False;
3582
3583          --  If either type has constraint error bounds, then consider that
3584          --  they match to avoid junk cascaded errors here.
3585
3586          elsif not Is_OK_Static_Subtype (T1)
3587            or else not Is_OK_Static_Subtype (T2)
3588          then
3589             return True;
3590
3591          --  Base types must match, but we don't check that (should
3592          --  we???) but we do at least check that both types are
3593          --  real, or both types are not real.
3594
3595          elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
3596             return False;
3597
3598          --  Here we check the bounds
3599
3600          else
3601             declare
3602                LB1 : constant Node_Id := Type_Low_Bound  (T1);
3603                HB1 : constant Node_Id := Type_High_Bound (T1);
3604                LB2 : constant Node_Id := Type_Low_Bound  (T2);
3605                HB2 : constant Node_Id := Type_High_Bound (T2);
3606
3607             begin
3608                if Is_Real_Type (T1) then
3609                   return
3610                     (Expr_Value_R (LB1) > Expr_Value_R (HB1))
3611                       or else
3612                     (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
3613                        and then
3614                      Expr_Value_R (HB1) <= Expr_Value_R (HB2));
3615
3616                else
3617                   return
3618                     (Expr_Value (LB1) > Expr_Value (HB1))
3619                       or else
3620                     (Expr_Value (LB2) <= Expr_Value (LB1)
3621                        and then
3622                      Expr_Value (HB1) <= Expr_Value (HB2));
3623                end if;
3624             end;
3625          end if;
3626
3627       elsif Is_Access_Type (T1) then
3628          return not Is_Constrained (T2)
3629            or else Subtypes_Statically_Match
3630                      (Designated_Type (T1), Designated_Type (T2));
3631
3632       else
3633          return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
3634            or else Subtypes_Statically_Match (T1, T2);
3635       end if;
3636    end Subtypes_Statically_Compatible;
3637
3638    -------------------------------
3639    -- Subtypes_Statically_Match --
3640    -------------------------------
3641
3642    --  Subtypes statically match if they have statically matching constraints
3643    --  (RM 4.9.1(2)). Constraints statically match if there are none, or if
3644    --  they are the same identical constraint, or if they are static and the
3645    --  values match (RM 4.9.1(1)).
3646
3647    function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
3648    begin
3649       --  A type always statically matches itself
3650
3651       if T1 = T2 then
3652          return True;
3653
3654       --  Scalar types
3655
3656       elsif Is_Scalar_Type (T1) then
3657
3658          --  Base types must be the same
3659
3660          if Base_Type (T1) /= Base_Type (T2) then
3661             return False;
3662          end if;
3663
3664          --  A constrained numeric subtype never matches an unconstrained
3665          --  subtype, i.e. both types must be constrained or unconstrained.
3666
3667          --  To understand the requirement for this test, see RM 4.9.1(1).
3668          --  As is made clear in RM 3.5.4(11), type Integer, for example
3669          --  is a constrained subtype with constraint bounds matching the
3670          --  bounds of its corresponding uncontrained base type. In this
3671          --  situation, Integer and Integer'Base do not statically match,
3672          --  even though they have the same bounds.
3673
3674          --  We only apply this test to types in Standard and types that
3675          --  appear in user programs. That way, we do not have to be
3676          --  too careful about setting Is_Constrained right for itypes.
3677
3678          if Is_Numeric_Type (T1)
3679            and then (Is_Constrained (T1) /= Is_Constrained (T2))
3680            and then (Scope (T1) = Standard_Standard
3681                       or else Comes_From_Source (T1))
3682            and then (Scope (T2) = Standard_Standard
3683                       or else Comes_From_Source (T2))
3684          then
3685             return False;
3686          end if;
3687
3688          --  If there was an error in either range, then just assume
3689          --  the types statically match to avoid further junk errors
3690
3691          if Error_Posted (Scalar_Range (T1))
3692               or else
3693             Error_Posted (Scalar_Range (T2))
3694          then
3695             return True;
3696          end if;
3697
3698          --  Otherwise both types have bound that can be compared
3699
3700          declare
3701             LB1 : constant Node_Id := Type_Low_Bound  (T1);
3702             HB1 : constant Node_Id := Type_High_Bound (T1);
3703             LB2 : constant Node_Id := Type_Low_Bound  (T2);
3704             HB2 : constant Node_Id := Type_High_Bound (T2);
3705
3706          begin
3707             --  If the bounds are the same tree node, then match
3708
3709             if LB1 = LB2 and then HB1 = HB2 then
3710                return True;
3711
3712             --  Otherwise bounds must be static and identical value
3713
3714             else
3715                if not Is_Static_Subtype (T1)
3716                  or else not Is_Static_Subtype (T2)
3717                then
3718                   return False;
3719
3720                --  If either type has constraint error bounds, then say
3721                --  that they match to avoid junk cascaded errors here.
3722
3723                elsif not Is_OK_Static_Subtype (T1)
3724                  or else not Is_OK_Static_Subtype (T2)
3725                then
3726                   return True;
3727
3728                elsif Is_Real_Type (T1) then
3729                   return
3730                     (Expr_Value_R (LB1) = Expr_Value_R (LB2))
3731                       and then
3732                     (Expr_Value_R (HB1) = Expr_Value_R (HB2));
3733
3734                else
3735                   return
3736                     Expr_Value (LB1) = Expr_Value (LB2)
3737                       and then
3738                     Expr_Value (HB1) = Expr_Value (HB2);
3739                end if;
3740             end if;
3741          end;
3742
3743       --  Type with discriminants
3744
3745       elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
3746          if Has_Discriminants (T1) /= Has_Discriminants (T2) then
3747             return False;
3748          end if;
3749
3750          declare
3751             DL1 : constant Elist_Id := Discriminant_Constraint (T1);
3752             DL2 : constant Elist_Id := Discriminant_Constraint (T2);
3753
3754             DA1 : Elmt_Id := First_Elmt (DL1);
3755             DA2 : Elmt_Id := First_Elmt (DL2);
3756
3757          begin
3758             if DL1 = DL2 then
3759                return True;
3760
3761             elsif Is_Constrained (T1) /= Is_Constrained (T2) then
3762                return False;
3763             end if;
3764
3765             while Present (DA1) loop
3766                declare
3767                   Expr1 : constant Node_Id := Node (DA1);
3768                   Expr2 : constant Node_Id := Node (DA2);
3769
3770                begin
3771                   if not Is_Static_Expression (Expr1)
3772                     or else not Is_Static_Expression (Expr2)
3773                   then
3774                      return False;
3775
3776                   --  If either expression raised a constraint error,
3777                   --  consider the expressions as matching, since this
3778                   --  helps to prevent cascading errors.
3779
3780                   elsif Raises_Constraint_Error (Expr1)
3781                     or else Raises_Constraint_Error (Expr2)
3782                   then
3783                      null;
3784
3785                   elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
3786                      return False;
3787                   end if;
3788                end;
3789
3790                Next_Elmt (DA1);
3791                Next_Elmt (DA2);
3792             end loop;
3793          end;
3794
3795          return True;
3796
3797       --  A definite type does not match an indefinite or classwide type.
3798
3799       elsif
3800          Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
3801       then
3802          return False;
3803
3804       --  Array type
3805
3806       elsif Is_Array_Type (T1) then
3807
3808          --  If either subtype is unconstrained then both must be,
3809          --  and if both are unconstrained then no further checking
3810          --  is needed.
3811
3812          if not Is_Constrained (T1) or else not Is_Constrained (T2) then
3813             return not (Is_Constrained (T1) or else Is_Constrained (T2));
3814          end if;
3815
3816          --  Both subtypes are constrained, so check that the index
3817          --  subtypes statically match.
3818
3819          declare
3820             Index1 : Node_Id := First_Index (T1);
3821             Index2 : Node_Id := First_Index (T2);
3822
3823          begin
3824             while Present (Index1) loop
3825                if not
3826                  Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
3827                then
3828                   return False;
3829                end if;
3830
3831                Next_Index (Index1);
3832                Next_Index (Index2);
3833             end loop;
3834
3835             return True;
3836          end;
3837
3838       elsif Is_Access_Type (T1) then
3839          return Subtypes_Statically_Match
3840                   (Designated_Type (T1),
3841                    Designated_Type (T2));
3842
3843       --  All other types definitely match
3844
3845       else
3846          return True;
3847       end if;
3848    end Subtypes_Statically_Match;
3849
3850    ----------
3851    -- Test --
3852    ----------
3853
3854    function Test (Cond : Boolean) return Uint is
3855    begin
3856       if Cond then
3857          return Uint_1;
3858       else
3859          return Uint_0;
3860       end if;
3861    end Test;
3862
3863    ---------------------------------
3864    -- Test_Expression_Is_Foldable --
3865    ---------------------------------
3866
3867    --  One operand case
3868
3869    procedure Test_Expression_Is_Foldable
3870      (N    : Node_Id;
3871       Op1  : Node_Id;
3872       Stat : out Boolean;
3873       Fold : out Boolean)
3874    is
3875    begin
3876       Stat := False;
3877
3878       --  If operand is Any_Type, just propagate to result and do not
3879       --  try to fold, this prevents cascaded errors.
3880
3881       if Etype (Op1) = Any_Type then
3882          Set_Etype (N, Any_Type);
3883          Fold := False;
3884          return;
3885
3886       --  If operand raises constraint error, then replace node N with the
3887       --  raise constraint error node, and we are obviously not foldable.
3888       --  Note that this replacement inherits the Is_Static_Expression flag
3889       --  from the operand.
3890
3891       elsif Raises_Constraint_Error (Op1) then
3892          Rewrite_In_Raise_CE (N, Op1);
3893          Fold := False;
3894          return;
3895
3896       --  If the operand is not static, then the result is not static, and
3897       --  all we have to do is to check the operand since it is now known
3898       --  to appear in a non-static context.
3899
3900       elsif not Is_Static_Expression (Op1) then
3901          Check_Non_Static_Context (Op1);
3902          Fold := Compile_Time_Known_Value (Op1);
3903          return;
3904
3905       --   An expression of a formal modular type is not foldable because
3906       --   the modulus is unknown.
3907
3908       elsif Is_Modular_Integer_Type (Etype (Op1))
3909         and then Is_Generic_Type (Etype (Op1))
3910       then
3911          Check_Non_Static_Context (Op1);
3912          Fold := False;
3913          return;
3914
3915       --  Here we have the case of an operand whose type is OK, which is
3916       --  static, and which does not raise constraint error, we can fold.
3917
3918       else
3919          Set_Is_Static_Expression (N);
3920          Fold := True;
3921          Stat := True;
3922       end if;
3923    end Test_Expression_Is_Foldable;
3924
3925    --  Two operand case
3926
3927    procedure Test_Expression_Is_Foldable
3928      (N    : Node_Id;
3929       Op1  : Node_Id;
3930       Op2  : Node_Id;
3931       Stat : out Boolean;
3932       Fold : out Boolean)
3933    is
3934       Rstat : constant Boolean := Is_Static_Expression (Op1)
3935                                     and then Is_Static_Expression (Op2);
3936
3937    begin
3938       Stat := False;
3939
3940       --  If either operand is Any_Type, just propagate to result and
3941       --  do not try to fold, this prevents cascaded errors.
3942
3943       if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
3944          Set_Etype (N, Any_Type);
3945          Fold := False;
3946          return;
3947
3948       --  If left operand raises constraint error, then replace node N with
3949       --  the raise constraint error node, and we are obviously not foldable.
3950       --  Is_Static_Expression is set from the two operands in the normal way,
3951       --  and we check the right operand if it is in a non-static context.
3952
3953       elsif Raises_Constraint_Error (Op1) then
3954          if not Rstat then
3955             Check_Non_Static_Context (Op2);
3956          end if;
3957
3958          Rewrite_In_Raise_CE (N, Op1);
3959          Set_Is_Static_Expression (N, Rstat);
3960          Fold := False;
3961          return;
3962
3963       --  Similar processing for the case of the right operand. Note that
3964       --  we don't use this routine for the short-circuit case, so we do
3965       --  not have to worry about that special case here.
3966
3967       elsif Raises_Constraint_Error (Op2) then
3968          if not Rstat then
3969             Check_Non_Static_Context (Op1);
3970          end if;
3971
3972          Rewrite_In_Raise_CE (N, Op2);
3973          Set_Is_Static_Expression (N, Rstat);
3974          Fold := False;
3975          return;
3976
3977       --  Exclude expressions of a generic modular type, as above.
3978
3979       elsif Is_Modular_Integer_Type (Etype (Op1))
3980         and then Is_Generic_Type (Etype (Op1))
3981       then
3982          Check_Non_Static_Context (Op1);
3983          Fold := False;
3984          return;
3985
3986       --  If result is not static, then check non-static contexts on operands
3987       --  since one of them may be static and the other one may not be static
3988
3989       elsif not Rstat then
3990          Check_Non_Static_Context (Op1);
3991          Check_Non_Static_Context (Op2);
3992          Fold := Compile_Time_Known_Value (Op1)
3993                    and then Compile_Time_Known_Value (Op2);
3994          return;
3995
3996       --  Else result is static and foldable. Both operands are static,
3997       --  and neither raises constraint error, so we can definitely fold.
3998
3999       else
4000          Set_Is_Static_Expression (N);
4001          Fold := True;
4002          Stat := True;
4003          return;
4004       end if;
4005    end Test_Expression_Is_Foldable;
4006
4007    --------------
4008    -- To_Bits --
4009    --------------
4010
4011    procedure To_Bits (U : Uint; B : out Bits) is
4012    begin
4013       for J in 0 .. B'Last loop
4014          B (J) := (U / (2 ** J)) mod 2 /= 0;
4015       end loop;
4016    end To_Bits;
4017
4018    --------------------
4019    -- Why_Not_Static --
4020    --------------------
4021
4022    procedure Why_Not_Static (Expr : Node_Id) is
4023       N   : constant Node_Id   := Original_Node (Expr);
4024       Typ : Entity_Id;
4025       E   : Entity_Id;
4026
4027       procedure Why_Not_Static_List (L : List_Id);
4028       --  A version that can be called on a list of expressions. Finds
4029       --  all non-static violations in any element of the list.
4030
4031       -------------------------
4032       -- Why_Not_Static_List --
4033       -------------------------
4034
4035       procedure Why_Not_Static_List (L : List_Id) is
4036          N : Node_Id;
4037
4038       begin
4039          if Is_Non_Empty_List (L) then
4040             N := First (L);
4041             while Present (N) loop
4042                Why_Not_Static (N);
4043                Next (N);
4044             end loop;
4045          end if;
4046       end Why_Not_Static_List;
4047
4048    --  Start of processing for Why_Not_Static
4049
4050    begin
4051       --  If in ACATS mode (debug flag 2), then suppress all these
4052       --  messages, this avoids massive updates to the ACATS base line.
4053
4054       if Debug_Flag_2 then
4055          return;
4056       end if;
4057
4058       --  Ignore call on error or empty node
4059
4060       if No (Expr) or else Nkind (Expr) = N_Error then
4061          return;
4062       end if;
4063
4064       --  Preprocessing for sub expressions
4065
4066       if Nkind (Expr) in N_Subexpr then
4067
4068          --  Nothing to do if expression is static
4069
4070          if Is_OK_Static_Expression (Expr) then
4071             return;
4072          end if;
4073
4074          --  Test for constraint error raised
4075
4076          if Raises_Constraint_Error (Expr) then
4077             Error_Msg_N
4078               ("expression raises exception, cannot be static " &
4079                "('R'M 4.9(34))!", N);
4080             return;
4081          end if;
4082
4083          --  If no type, then something is pretty wrong, so ignore
4084
4085          Typ := Etype (Expr);
4086
4087          if No (Typ) then
4088             return;
4089          end if;
4090
4091          --  Type must be scalar or string type
4092
4093          if not Is_Scalar_Type (Typ)
4094            and then not Is_String_Type (Typ)
4095          then
4096             Error_Msg_N
4097               ("static expression must have scalar or string type " &
4098                "('R'M 4.9(2))!", N);
4099             return;
4100          end if;
4101       end if;
4102
4103       --  If we got through those checks, test particular node kind
4104
4105       case Nkind (N) is
4106          when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
4107             E := Entity (N);
4108
4109             if Is_Named_Number (E) then
4110                null;
4111
4112             elsif Ekind (E) = E_Constant then
4113                if not Is_Static_Expression (Constant_Value (E)) then
4114                   Error_Msg_NE
4115                     ("& is not a static constant ('R'M 4.9(5))!", N, E);
4116                end if;
4117
4118             else
4119                Error_Msg_NE
4120                  ("& is not static constant or named number " &
4121                   "('R'M 4.9(5))!", N, E);
4122             end if;
4123
4124          when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
4125             if Nkind (N) in N_Op_Shift then
4126                Error_Msg_N
4127                 ("shift functions are never static ('R'M 4.9(6,18))!", N);
4128
4129             else
4130                Why_Not_Static (Left_Opnd (N));
4131                Why_Not_Static (Right_Opnd (N));
4132             end if;
4133
4134          when N_Unary_Op =>
4135             Why_Not_Static (Right_Opnd (N));
4136
4137          when N_Attribute_Reference =>
4138             Why_Not_Static_List (Expressions (N));
4139
4140             E := Etype (Prefix (N));
4141
4142             if E = Standard_Void_Type then
4143                return;
4144             end if;
4145
4146             --  Special case non-scalar'Size since this is a common error
4147
4148             if Attribute_Name (N) = Name_Size then
4149                Error_Msg_N
4150                  ("size attribute is only static for scalar type " &
4151                   "('R'M 4.9(7,8))", N);
4152
4153             --  Flag array cases
4154
4155             elsif Is_Array_Type (E) then
4156                if Attribute_Name (N) /= Name_First
4157                     and then
4158                   Attribute_Name (N) /= Name_Last
4159                     and then
4160                   Attribute_Name (N) /= Name_Length
4161                then
4162                   Error_Msg_N
4163                     ("static array attribute must be Length, First, or Last " &
4164                      "('R'M 4.9(8))!", N);
4165
4166                --  Since we know the expression is not-static (we already
4167                --  tested for this, must mean array is not static).
4168
4169                else
4170                   Error_Msg_N
4171                     ("prefix is non-static array ('R'M 4.9(8))!", Prefix (N));
4172                end if;
4173
4174                return;
4175
4176             --  Special case generic types, since again this is a common
4177             --  source of confusion.
4178
4179             elsif Is_Generic_Actual_Type (E)
4180                     or else
4181                   Is_Generic_Type (E)
4182             then
4183                Error_Msg_N
4184                  ("attribute of generic type is never static " &
4185                   "('R'M 4.9(7,8))!", N);
4186
4187             elsif Is_Static_Subtype (E) then
4188                null;
4189
4190             elsif Is_Scalar_Type (E) then
4191                Error_Msg_N
4192                  ("prefix type for attribute is not static scalar subtype " &
4193                   "('R'M 4.9(7))!", N);
4194
4195             else
4196                Error_Msg_N
4197                  ("static attribute must apply to array/scalar type " &
4198                   "('R'M 4.9(7,8))!", N);
4199             end if;
4200
4201          when N_String_Literal =>
4202             Error_Msg_N
4203               ("subtype of string literal is non-static ('R'M 4.9(4))!", N);
4204
4205          when N_Explicit_Dereference =>
4206             Error_Msg_N
4207               ("explicit dereference is never static ('R'M 4.9)!", N);
4208
4209          when N_Function_Call =>
4210             Why_Not_Static_List (Parameter_Associations (N));
4211             Error_Msg_N ("non-static function call ('R'M 4.9(6,18))!", N);
4212
4213          when N_Parameter_Association =>
4214             Why_Not_Static (Explicit_Actual_Parameter (N));
4215
4216          when N_Indexed_Component =>
4217             Error_Msg_N
4218               ("indexed component is never static ('R'M 4.9)!", N);
4219
4220          when N_Procedure_Call_Statement =>
4221             Error_Msg_N
4222               ("procedure call is never static ('R'M 4.9)!", N);
4223
4224          when N_Qualified_Expression =>
4225             Why_Not_Static (Expression (N));
4226
4227          when N_Aggregate | N_Extension_Aggregate =>
4228             Error_Msg_N
4229               ("an aggregate is never static ('R'M 4.9)!", N);
4230
4231          when N_Range =>
4232             Why_Not_Static (Low_Bound (N));
4233             Why_Not_Static (High_Bound (N));
4234
4235          when N_Range_Constraint =>
4236             Why_Not_Static (Range_Expression (N));
4237
4238          when N_Subtype_Indication =>
4239             Why_Not_Static (Constraint (N));
4240
4241          when N_Selected_Component =>
4242             Error_Msg_N
4243               ("selected component is never static ('R'M 4.9)!", N);
4244
4245          when N_Slice =>
4246             Error_Msg_N
4247               ("slice is never static ('R'M 4.9)!", N);
4248
4249          when N_Type_Conversion =>
4250             Why_Not_Static (Expression (N));
4251
4252             if not Is_Scalar_Type (Etype (Prefix (N)))
4253               or else not Is_Static_Subtype (Etype (Prefix (N)))
4254             then
4255                Error_Msg_N
4256                  ("static conversion requires static scalar subtype result " &
4257                   "('R'M 4.9(9))!", N);
4258             end if;
4259
4260          when N_Unchecked_Type_Conversion =>
4261             Error_Msg_N
4262               ("unchecked type conversion is never static ('R'M 4.9)!", N);
4263
4264          when others =>
4265             null;
4266
4267       end case;
4268    end Why_Not_Static;
4269
4270 end Sem_Eval;