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